company.el

   1 ;;; company.el --- extensible inline text completion mechanism
   2 ;;
   3 ;; Copyright (C) 2009 Nikolaj Schumacher
   4 ;;
   5 ;; Author: Nikolaj Schumacher <bugs * nschum de>
   6 ;; Version: 0.1
   7 ;; Keywords: abbrev, convenience, matchis
   8 ;; URL: http://nschum.de/src/emacs/company/
   9 ;; Compatibility: GNU Emacs 22.x, GNU Emacs 23.x
  10 ;;
  11 ;; This file is NOT part of GNU Emacs.
  12 ;;
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License
  15 ;; as published by the Free Software Foundation; either version 2
  16 ;; of the License, or (at your option) any later version.
  17 ;;
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25 ;;
  26 ;;; Commentary:
  27 ;;
  28 ;; Company is a modular completion mechanism.  Modules for retrieving completion
  29 ;; candidates are called back-ends, modules for displaying them are front-ends.
  30 ;;
  31 ;; Company comes with many back-ends, e.g. `company-elisp'.  These are
  32 ;; distributed in individual files and can be used individually.
  33 ;;
  34 ;; Place company.el and the back-ends you want to use in a directory and add the
  35 ;; following to your .emacs:
  36 ;; (add-to-list 'load-path "/path/to/company")
  37 ;; (autoload 'company-mode "company" nil t)
  38 ;;
  39 ;; Enable company-mode with M-x company-mode.  For further information look at
  40 ;; the documentation for `company-mode' (C-h f company-mode RET)
  41 ;;
  42 ;; To write your own back-end, look at the documentation for `company-backends'.
  43 ;; Here is a simple example completing "foo":
  44 ;;
  45 ;; (defun company-my-backend (command &optional arg &rest ignored)
  46 ;;   (case command
  47 ;;     ('prefix (when (looking-back "foo\\>")
  48 ;;                (match-string 0)))
  49 ;;     ('candidates (list "foobar" "foobaz" "foobarbaz"))
  50 ;;     ('meta (format "This value is named %s" arg))))
  51 ;;
  52 ;; Known Issues:
  53 ;; When point is at the very end of the buffer, the pseudo-tooltip appears very
  54 ;; wrong.
  55 ;;
  56 ;;; Change Log:
  57 ;;
  58 ;; 2009-03-20 (0.1)
  59 ;;    Initial release.
  60 ;;
  61 ;;; Code:
  62
  63 (eval-when-compile (require 'cl))
  64
  65 (add-to-list 'debug-ignored-errors
  66              "^Pseudo tooltip frontend cannot be used twice$")
  67 (add-to-list 'debug-ignored-errors "^Preview frontend cannot be used twice$")
  68 (add-to-list 'debug-ignored-errors "^Echo area cannot be used twice$")
  69 (add-to-list 'debug-ignored-errors "^No documentation available$")
  70 (add-to-list 'debug-ignored-errors "^Company not enabled$")
  71 (add-to-list 'debug-ignored-errors "^Company not in search mode$")
  72
  73 (defgroup company nil
  74   "Extensible inline text completion mechanism"
  75   :group 'abbrev
  76   :group 'convenience
  77   :group 'maching)
  78
  79 (defface company-tooltip
  80   '((t :background "yellow"
  81        :foreground "black"))
  82   "*Face used for the tool tip."
  83   :group 'company)
  84
  85 (defface company-tooltip-selection
  86   '((default :inherit company-tooltip)
  87     (((class color) (min-colors 88)) (:background "orange1"))
  88     (t (:background "green")))
  89   "*Face used for the selection in the tool tip."
  90   :group 'company)
  91
  92 (defface company-tooltip-common
  93   '((t :inherit company-tooltip
  94        :foreground "red"))
  95   "*Face used for the common completion in the tool tip."
  96   :group 'company)
  97
  98 (defface company-tooltip-common-selection
  99   '((t :inherit company-tooltip-selection
 100        :foreground "red"))
 101   "*Face used for the selected common completion in the tool tip."
 102   :group 'company)
 103
 104 (defcustom company-tooltip-limit 10
 105   "*The maximum number of candidates in the tool tip"
 106   :group 'company
 107   :type 'integer)
 108
 109 (defface company-preview
 110   '((t :background "blue4"
 111        :foreground "wheat"))
 112   "*Face used for the completion preview."
 113   :group 'company)
 114
 115 (defface company-preview-common
 116   '((t :inherit company-preview
 117        :foreground "red"))
 118   "*Face used for the common part of the completion preview."
 119   :group 'company)
 120
 121 (defface company-echo nil
 122   "*Face used for completions in the echo area."
 123   :group 'company)
 124
 125 (defface company-echo-common
 126   '((((background dark)) (:foreground "firebrick1"))
 127     (((background light)) (:background "firebrick4")))
 128   "*Face used for the common part of completions in the echo area."
 129   :group 'company)
 130
 131 (defun company-frontends-set (variable value)
 132   ;; uniquify
 133   (let ((remainder value))
 134     (setcdr remainder (delq (car remainder) (cdr remainder))))
 135   (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
 136        (memq 'company-pseudo-tooltip-frontend value)
 137        (error "Pseudo tooltip frontend cannot be used twice"))
 138   (and (memq 'company-preview-if-just-one-frontend value)
 139        (memq 'company-preview-frontend value)
 140        (error "Preview frontend cannot be used twice"))
 141   (and (memq 'company-echo value)
 142        (memq 'company-echo-metadata-frontend value)
 143        (error "Echo area cannot be used twice"))
 144   ;; preview must come last
 145   (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend))
 146     (when (memq f value)
 147       (setq value (append (delq f value) (list f)))))
 148   (set variable value))
 149
 150 (defcustom company-frontends '(company-pseudo-tooltip-unless-just-one-frontend
 151                                company-preview-if-just-one-frontend
 152                                company-echo-metadata-frontend)
 153   "*The list of active front-ends (visualizations).
 154 Each front-end is a function that takes one argument.  It is called with
 155 one of the following arguments:
 156
 157 'show: When the visualization should start.
 158
 159 'hide: When the visualization should end.
 160
 161 'update: When the data has been updated.
 162
 163 'pre-command: Before every command that is executed while the
 164 visualization is active.
 165
 166 'post-command: After every command that is executed while the
 167 visualization is active.
 168
 169 The visualized data is stored in `company-prefix', `company-candidates',
 170 `company-common', `company-selection', `company-point' and
 171 `company-search-string'."
 172   :set 'company-frontends-set
 173   :group 'company
 174   :type '(repeat (choice (const :tag "echo" company-echo-frontend)
 175                          (const :tag "pseudo tooltip"
 176                                 company-pseudo-tooltip-frontend)
 177                          (const :tag "pseudo tooltip, multiple only"
 178                                 company-pseudo-tooltip-unless-just-one-frontend)
 179                          (const :tag "preview" company-preview-frontend)
 180                          (const :tag "preview, unique only"
 181                                 company-preview-if-just-one-frontend)
 182                          (function :tag "custom function" nil))))
 183
 184 (defcustom company-backends '(company-elisp company-nxml company-css
 185                               company-semantic company-gtags company-oddmuse
 186                               company-files company-dabbrev)
 187   "*The list of active back-ends (completion engines).
 188 Each back-end is a function that takes a variable number of arguments.
 189 The first argument is the command requested from the back-end.  It is one
 190 of the following:
 191
 192 'prefix: The back-end should return the text to be completed.  It must be
 193 text immediately before `point'.  Returning nil passes control to the next
 194 back-end.
 195
 196 'candidates: The second argument is the prefix to be completed.  The
 197 return value should be a list of candidates that start with the prefix.
 198
 199 Optional commands:
 200
 201 'sorted: The back-end may return t here to indicate that the candidates
 202 are sorted and will not need to be sorted again.
 203
 204 'no-cache: Usually company doesn't ask for candidates again as completion
 205 progresses, unless the back-end returns t for this command.  The second
 206 argument is the latest prefix.
 207
 208 'meta: The second argument is a completion candidate.  The back-end should
 209 return a (short) documentation string for it.
 210
 211 'doc-buffer: The second argument is a completion candidate.  The back-end should
 212 create a buffer (preferably with `company-doc-buffer'), fill it with
 213 documentation and return it.
 214
 215 The back-end should return nil for all commands it does not support or
 216 does not know about."
 217   :group 'company
 218   :type '(repeat (function :tag "function" nil)))
 219
 220 (defcustom company-minimum-prefix-length 3
 221   "*The minimum prefix length for automatic completion."
 222   :group 'company
 223   :type '(integer :tag "prefix length"))
 224
 225 (defcustom company-idle-delay .7
 226   "*The idle delay in seconds until automatic completions starts.
 227 A value of nil means never complete automatically, t means complete
 228 immediately when a prefix of `company-minimum-prefix-length' is reached."
 229   :group 'company
 230   :type '(choice (const :tag "never (nil)" nil)
 231                  (const :tag "immediate (t)" t)
 232                  (number :tag "seconds")))
 233
 234 ;;; mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 235
 236 (defvar company-mode-map (make-sparse-keymap)
 237   "Keymap used by `company-mode'.")
 238
 239 (defvar company-active-map
 240   (let ((keymap (make-sparse-keymap)))
 241     (define-key keymap (kbd "M-n") 'company-select-next)
 242     (define-key keymap (kbd "M-p") 'company-select-previous)
 243     (define-key keymap (kbd "<down>") 'company-select-next)
 244     (define-key keymap (kbd "<up>") 'company-select-previous)
 245     (define-key keymap "\C-m" 'company-complete-selection)
 246     (define-key keymap "\t" 'company-complete-common)
 247     (define-key keymap (kbd "<f1>") 'company-show-doc-buffer)
 248     (define-key keymap "\C-s" 'company-search-candidates)
 249     keymap)
 250   "Keymap that is enabled during an active completion.")
 251
 252 ;;;###autoload
 253 (define-minor-mode company-mode
 254   "\"complete anything\"; in in-buffer completion framework.
 255 Completion starts automatically, depending on the values
 256 `company-idle-delay' and `company-minimum-prefix-length'
 257
 258 Completion can be controlled with the commands:
 259 `company-complete-common', `company-complete-selection', `company-complete',
 260 `company-select-next', `company-select-previous'.
 261
 262 Completions can be searched with `company-search-candidates'.
 263
 264 The completion data is retrieved using `company-backends' and displayed using
 265 `company-frontends'.
 266
 267 regular keymap:
 268
 269 \\{company-mode-map}
 270 keymap during active completions:
 271
 272 \\{company-active-map}"
 273   nil " comp" company-mode-map
 274   (if company-mode
 275       (progn
 276         (add-hook 'pre-command-hook 'company-pre-command nil t)
 277         (add-hook 'post-command-hook 'company-post-command nil t))
 278     (remove-hook 'pre-command-hook 'company-pre-command t)
 279     (remove-hook 'post-command-hook 'company-post-command t)
 280     (company-cancel)
 281     (kill-local-variable 'company-point)))
 282
 283 ;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 284
 285 (defvar company-overriding-keymap-bound nil)
 286 (make-variable-buffer-local 'company-overriding-keymap-bound)
 287
 288 (defvar company-old-keymap nil)
 289 (make-variable-buffer-local 'company-old-keymap)
 290
 291 (defvar company-my-keymap nil)
 292 (make-variable-buffer-local 'company-my-keymap)
 293
 294 (defsubst company-enable-overriding-keymap (keymap)
 295   (setq company-my-keymap keymap)
 296   (when company-overriding-keymap-bound
 297     (company-uninstall-map)))
 298
 299 (defun company-install-map ()
 300   (unless (or company-overriding-keymap-bound
 301               (null company-my-keymap))
 302     (setq company-old-keymap overriding-terminal-local-map
 303           overriding-terminal-local-map company-my-keymap
 304           company-overriding-keymap-bound t)))
 305
 306 (defun company-uninstall-map ()
 307   (when (and company-overriding-keymap-bound
 308              (eq overriding-terminal-local-map company-my-keymap))
 309     (setq overriding-terminal-local-map company-old-keymap
 310           company-overriding-keymap-bound nil)))
 311
 312 ;; Hack:
 313 ;; Emacs calculates the active keymaps before reading the event.  That means we
 314 ;; cannot change the keymap from a timer.  So we send a bogus command.
 315 (defun company-ignore ()
 316   (interactive))
 317
 318 (global-set-key '[31415926] 'company-ignore)
 319
 320 (defun company-input-noop ()
 321   (push 31415926 unread-command-events))
 322
 323 ;;; backends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 324
 325 (defun company-grab (regexp &optional expression)
 326   (when (looking-back regexp)
 327     (or (match-string-no-properties (or expression 0)) "")))
 328
 329 (defun company-in-string-or-comment (&optional point)
 330   (let ((pos (syntax-ppss)))
 331     (or (nth 3 pos) (nth 4 pos) (nth 7 pos))))
 332
 333 ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 334
 335 (defvar company-backend nil)
 336 (make-variable-buffer-local 'company-backend)
 337
 338 (defvar company-prefix nil)
 339 (make-variable-buffer-local 'company-prefix)
 340
 341 (defvar company-candidates nil)
 342 (make-variable-buffer-local 'company-candidates)
 343
 344 (defvar company-candidates-length nil)
 345 (make-variable-buffer-local 'company-candidates-length)
 346
 347 (defvar company-candidates-cache nil)
 348 (make-variable-buffer-local 'company-candidates-cache)
 349
 350 (defvar company-candidates-predicate nil)
 351 (make-variable-buffer-local 'company-candidates-predicate)
 352
 353 (defvar company-common nil)
 354 (make-variable-buffer-local 'company-common)
 355
 356 (defvar company-selection 0)
 357 (make-variable-buffer-local 'company-selection)
 358
 359 (defvar company-selection-changed nil)
 360 (make-variable-buffer-local 'company-selection-changed)
 361
 362 (defvar company-point nil)
 363 (make-variable-buffer-local 'company-point)
 364
 365 (defvar company-timer nil)
 366
 367 (defvar company-disabled-backends nil)
 368
 369 (defsubst company-strip-prefix (str)
 370   (substring str (length company-prefix)))
 371
 372 (defsubst company-reformat (candidate)
 373   ;; company-ispell needs this, because the results are always lower-case
 374   ;; It's mory efficient to fix it only when they are displayed.
 375   (concat company-prefix (substring candidate (length company-prefix))))
 376
 377 (defsubst company-should-complete (prefix)
 378   (and (eq company-idle-delay t)
 379        (>= (length prefix) company-minimum-prefix-length)))
 380
 381 (defsubst company-call-frontends (command)
 382   (dolist (frontend company-frontends)
 383     (condition-case err
 384         (funcall frontend command)
 385       (error (error "Company: Front-end %s error \"%s\" on command %s"
 386                     frontend (error-message-string err) command)))))
 387
 388 (defsubst company-set-selection (selection &optional force-update)
 389   (setq selection (max 0 (min (1- company-candidates-length) selection)))
 390   (when (or force-update (not (equal selection company-selection)))
 391     (setq company-selection selection
 392           company-selection-changed t)
 393     (company-call-frontends 'update)))
 394
 395 (defun company-apply-predicate (candidates predicate)
 396   (let (new)
 397     (dolist (c candidates)
 398       (when (funcall predicate c)
 399         (push c new)))
 400     (nreverse new)))
 401
 402 (defun company-update-candidates (candidates)
 403   (setq company-candidates-length (length candidates))
 404   (if (> company-selection 0)
 405       ;; Try to restore the selection
 406       (let ((selected (nth company-selection company-candidates)))
 407         (setq company-selection 0
 408               company-candidates candidates)
 409         (when selected
 410           (while (and candidates (string< (pop candidates) selected))
 411             (incf company-selection))
 412           (unless candidates
 413             ;; Make sure selection isn't out of bounds.
 414             (setq company-selection (min (1- company-candidates-length)
 415                                          company-selection)))))
 416     (setq company-selection 0
 417           company-candidates candidates))
 418   ;; Calculate common.
 419   (let ((completion-ignore-case (funcall company-backend 'ignore-case)))
 420     (setq company-common (try-completion company-prefix company-candidates)))
 421   (when (eq company-common t)
 422     (setq company-candidates nil)))
 423
 424 (defsubst company-calculate-candidates (prefix)
 425   (setq company-prefix prefix)
 426   (company-update-candidates
 427    (or (cdr (assoc prefix company-candidates-cache))
 428        (when company-candidates-cache
 429          (let ((len (length prefix))
 430                (completion-ignore-case (funcall company-backend 'ignore-case))
 431                prev)
 432            (dotimes (i len)
 433              (when (setq prev (cdr (assoc (substring prefix 0 (- len i))
 434                                           company-candidates-cache)))
 435                (return (all-completions prefix prev))))))
 436        (let ((candidates (funcall company-backend 'candidates prefix)))
 437          (when company-candidates-predicate
 438            (setq candidates
 439                  (company-apply-predicate candidates
 440                                           company-candidates-predicate)))
 441          (unless (funcall company-backend 'sorted)
 442            (setq candidates (sort candidates 'string<)))
 443          candidates)))
 444   (unless (assoc prefix company-candidates-cache)
 445     (push (cons prefix company-candidates) company-candidates-cache))
 446   company-candidates)
 447
 448 (defun company-idle-begin (buf win tick pos)
 449   (and company-mode
 450        (eq buf (current-buffer))
 451        (eq win (selected-window))
 452        (eq tick (buffer-chars-modified-tick))
 453        (eq pos (point))
 454        (not company-candidates)
 455        (not (equal (point) company-point))
 456        (let ((company-idle-delay t))
 457          (company-begin)
 458          (when company-candidates
 459            (company-input-noop)
 460            (company-post-command)))))
 461
 462 (defun company-manual-begin ()
 463   (unless company-mode (error "Company not enabled"))
 464   (and company-mode
 465        (not company-candidates)
 466        (let ((company-idle-delay t)
 467              (company-minimum-prefix-length 0))
 468          (company-begin)))
 469   ;; Return non-nil if active.
 470   company-candidates)
 471
 472 (defun company-continue ()
 473   (when company-candidates
 474     (when (funcall company-backend 'no-cache company-prefix)
 475       ;; Don't complete existing candidates, fetch new ones.
 476       (setq company-candidates-cache nil))
 477     (let ((new-prefix (funcall company-backend 'prefix)))
 478       (unless (and (= (- (point) (length new-prefix))
 479                       (- company-point (length company-prefix)))
 480                    (or (equal company-prefix new-prefix)
 481                        (company-calculate-candidates new-prefix)))
 482         (setq company-candidates nil)))))
 483
 484 (defun company-begin ()
 485   (if (or buffer-read-only overriding-terminal-local-map overriding-local-map)
 486       ;; Don't complete in these cases.
 487       (setq company-candidates nil)
 488     (company-continue)
 489     (unless company-candidates
 490       (let (prefix)
 491         (dolist (backend company-backends)
 492           (unless (fboundp backend)
 493             (ignore-errors (require backend nil t)))
 494           (if (fboundp backend)
 495               (when (setq prefix (funcall backend 'prefix))
 496                 (when (company-should-complete prefix)
 497                   (setq company-backend backend)
 498                   (company-calculate-candidates prefix))
 499                 (return prefix))
 500             (unless (memq backend company-disabled-backends)
 501               (push backend company-disabled-backends)
 502               (message "Company back-end '%s' could not be initialized"
 503                        backend)))))))
 504   (if company-candidates
 505       (progn
 506         (setq company-point (point))
 507         (company-enable-overriding-keymap company-active-map)
 508         (company-call-frontends 'update))
 509     (company-cancel)))
 510
 511 (defun company-cancel ()
 512   (setq company-backend nil
 513         company-prefix nil
 514         company-candidates nil
 515         company-candidates-length nil
 516         company-candidates-cache nil
 517         company-candidates-predicate nil
 518         company-common nil
 519         company-selection 0
 520         company-selection-changed nil
 521         company-point nil)
 522   (when company-timer
 523     (cancel-timer company-timer))
 524   (company-search-mode 0)
 525   (company-call-frontends 'hide)
 526   (company-enable-overriding-keymap nil))
 527
 528 (defun company-abort ()
 529   (company-cancel)
 530   ;; Don't start again, unless started manually.
 531   (setq company-point (point)))
 532
 533 (defun company-pre-command ()
 534   (unless (eq this-command 'company-show-doc-buffer)
 535     (condition-case err
 536         (when company-candidates
 537           (company-call-frontends 'pre-command))
 538       (error (message "Company: An error occurred in pre-command")
 539              (message "%s" (error-message-string err))
 540              (company-cancel))))
 541   (when company-timer
 542     (cancel-timer company-timer))
 543   (company-uninstall-map))
 544
 545 (defun company-post-command ()
 546   (unless (eq this-command 'company-show-doc-buffer)
 547     (condition-case err
 548         (progn
 549           (unless (equal (point) company-point)
 550             (company-begin))
 551           (when company-candidates
 552             (company-call-frontends 'post-command))
 553           (when (numberp company-idle-delay)
 554             (setq company-timer
 555                   (run-with-timer company-idle-delay nil 'company-idle-begin
 556                                   (current-buffer) (selected-window)
 557                                   (buffer-chars-modified-tick) (point)))))
 558       (error (message "Company: An error occurred in post-command")
 559              (message "%s" (error-message-string err))
 560              (company-cancel))))
 561   (company-install-map))
 562
 563 ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 564
 565 (defvar company-search-string nil)
 566 (make-variable-buffer-local 'company-search-string)
 567
 568 (defvar company-search-lighter " Search: \"\"")
 569 (make-variable-buffer-local 'company-search-lighter)
 570
 571 (defvar company-search-old-map nil)
 572 (make-variable-buffer-local 'company-search-old-map)
 573
 574 (defvar company-search-old-selection 0)
 575 (make-variable-buffer-local 'company-search-old-selection)
 576
 577 (defun company-search (text lines)
 578   (let ((quoted (regexp-quote text))
 579         (i 0))
 580     (dolist (line lines)
 581       (when (string-match quoted line (length company-prefix))
 582         (return i))
 583       (incf i))))
 584
 585 (defun company-search-printing-char ()
 586   (interactive)
 587   (unless company-mode (error "Company not enabled"))
 588   (unless company-search-mode (error "Company not in search mode"))
 589   (setq company-search-string
 590         (concat (or company-search-string "") (string last-command-event))
 591         company-search-lighter (concat " Search: \"" company-search-string
 592                                         "\""))
 593   (let ((pos (company-search company-search-string
 594                               (nthcdr company-selection company-candidates))))
 595     (if (null pos)
 596         (ding)
 597       (company-set-selection (+ company-selection pos) t))))
 598
 599 (defun company-search-repeat-forward ()
 600   "Repeat the incremental search in completion candidates forward."
 601   (interactive)
 602   (unless company-mode (error "Company not enabled"))
 603   (unless company-search-mode (error "Company not in search mode"))
 604   (let ((pos (company-search company-search-string
 605                               (cdr (nthcdr company-selection
 606                                            company-candidates)))))
 607     (if (null pos)
 608         (ding)
 609       (company-set-selection (+ company-selection pos 1) t))))
 610
 611 (defun company-search-repeat-backward ()
 612   "Repeat the incremental search in completion candidates backwards."
 613   (interactive)
 614   (unless company-mode (error "Company not enabled"))
 615   (unless company-search-mode (error "Company not in search mode"))
 616   (let ((pos (company-search company-search-string
 617                               (nthcdr (- company-candidates-length
 618                                          company-selection)
 619                                       (reverse company-candidates)))))
 620     (if (null pos)
 621         (ding)
 622       (company-set-selection (- company-selection pos 1) t))))
 623
 624 (defsubst company-create-match-predicate (search-string)
 625   `(lambda (candidate)
 626      ,(if company-candidates-predicate
 627           `(and (string-match ,search-string candidate)
 628                 (funcall ,company-candidates-predicate candidate))
 629         `(string-match ,company-search-string candidate))))
 630
 631 (defun company-search-kill-others ()
 632   "Limit the completion candidates to the ones matching the search string."
 633   (interactive)
 634   (unless company-mode (error "Company not enabled"))
 635   (unless company-search-mode (error "Company not in search mode"))
 636   (let ((predicate (company-create-match-predicate company-search-string)))
 637     (setq company-candidates-predicate predicate)
 638     (company-update-candidates (company-apply-predicate company-candidates
 639                                                         predicate))
 640     (company-search-mode 0)
 641     (company-call-frontends 'update)))
 642
 643 (defun company-search-abort ()
 644   "Abort searching the completion candidates."
 645   (interactive)
 646   (unless company-mode (error "Company not enabled"))
 647   (unless company-search-mode (error "Company not in search mode"))
 648   (company-set-selection company-search-old-selection t)
 649   (company-search-mode 0))
 650
 651 (defun company-search-other-char ()
 652   (interactive)
 653   (unless company-mode (error "Company not enabled"))
 654   (unless company-search-mode (error "Company not in search mode"))
 655   (company-search-mode 0)
 656   (when last-input-event
 657     (clear-this-command-keys t)
 658     (setq unread-command-events (list last-input-event))))
 659
 660 (defvar company-search-map
 661   (let ((i 0)
 662         (keymap (make-keymap)))
 663     (if (fboundp 'max-char)
 664         (set-char-table-range (nth 1 keymap) (cons #x100 (max-char))
 665                               'company-search-printing-char)
 666       (with-no-warnings
 667         ;; obselete in Emacs 23
 668         (let ((l (generic-character-list))
 669               (table (nth 1 keymap)))
 670           (while l
 671             (set-char-table-default table (car l) 'isearch-printing-char)
 672             (setq l (cdr l))))))
 673     (define-key keymap [t] 'company-search-other-char)
 674     (while (< i ?\s)
 675       (define-key keymap (make-string 1 i) 'company-search-other-char)
 676       (incf i))
 677     (while (< i 256)
 678       (define-key keymap (vector i) 'company-search-printing-char)
 679       (incf i))
 680     (let ((meta-map (make-sparse-keymap)))
 681       (define-key keymap (char-to-string meta-prefix-char) meta-map)
 682       (define-key keymap [escape] meta-map))
 683     (define-key keymap (vector meta-prefix-char t) 'company-search-other-char)
 684     (define-key keymap "\e\e\e" 'company-search-other-char)
 685     (define-key keymap  [escape escape escape] 'company-search-other-char)
 686
 687     (define-key keymap "\C-g" 'company-search-abort)
 688     (define-key keymap "\C-s" 'company-search-repeat-forward)
 689     (define-key keymap "\C-r" 'company-search-repeat-backward)
 690     (define-key keymap "\C-o" 'company-search-kill-others)
 691     keymap)
 692   "Keymap used for incrementally searching the completion candidates.")
 693
 694 (define-minor-mode company-search-mode
 695   "Start searching the completion candidates incrementally.
 696
 697 \\<company-search-map>Search can be controlled with the commands:
 698 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
 699 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
 700 - `company-search-abort' (\\[company-search-abort])
 701
 702 Regular characters are appended to the search string.
 703
 704 The command `company-search-kill-others' (\\[company-search-kill-others]) uses
 705  the search string to limit the completion candidates."
 706   nil company-search-lighter nil
 707   (if company-search-mode
 708       (if (company-manual-begin)
 709           (progn
 710             (setq company-search-old-selection company-selection)
 711             (company-enable-overriding-keymap company-search-map)
 712             (company-call-frontends 'update))
 713         (setq company-search-mode nil))
 714     (kill-local-variable 'company-search-string)
 715     (kill-local-variable 'company-search-lighter)
 716     (kill-local-variable 'company-search-old-selection)
 717     (company-enable-overriding-keymap company-active-map)))
 718
 719 (defun company-search-candidates ()
 720   "Start searching the completion candidates incrementally.
 721
 722 \\<company-search-map>Search can be controlled with the commands:
 723 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
 724 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
 725 - `company-search-abort' (\\[company-search-abort])
 726
 727 Regular characters are appended to the search string.
 728
 729 The command `company-search-kill-others' (\\[company-search-kill-others]) uses
 730  the search string to limit the completion candidates."
 731   (interactive)
 732   (company-search-mode 1))
 733
 734 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 735
 736 (defun company-select-next ()
 737   "Select the next candidate in the list."
 738   (interactive)
 739   (when (company-manual-begin)
 740     (company-set-selection (1+ company-selection))))
 741
 742 (defun company-select-previous ()
 743   "Select the previous candidate in the list."
 744   (interactive)
 745   (when (company-manual-begin)
 746     (company-set-selection (1- company-selection))))
 747
 748 (defun company-complete-selection ()
 749   "Complete the selected candidate."
 750   (interactive)
 751   (when (company-manual-begin)
 752     (insert (company-strip-prefix (nth company-selection company-candidates)))
 753     (company-abort)))
 754
 755 (defun company-complete-common ()
 756   "Complete the common part of all candidates."
 757   (interactive)
 758   (when (company-manual-begin)
 759     (insert (company-strip-prefix company-common))))
 760
 761 (defun company-complete ()
 762   "Complete the common part of all candidates or the current selection.
 763 The first time this is called, the common part is completed, the second time, or
 764 when the selection has been changed, the selected candidate is completed."
 765   (interactive)
 766   (when (company-manual-begin)
 767     (if (or company-selection-changed
 768             (eq last-command 'company-complete-common))
 769         (call-interactively 'company-complete-selection)
 770       (call-interactively 'company-complete-common)
 771       (setq this-command 'company-complete-common))))
 772
 773 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 774
 775 (defconst company-space-strings-limit 100)
 776
 777 (defconst company-space-strings
 778   (let (lst)
 779     (dotimes (i company-space-strings-limit)
 780       (push (make-string (- company-space-strings-limit 1 i) ?\  ) lst))
 781     (apply 'vector lst)))
 782
 783 (defsubst company-space-string (len)
 784   (if (< len company-space-strings-limit)
 785       (aref company-space-strings len)
 786     (make-string len ?\ )))
 787
 788 (defsubst company-safe-substring (str from &optional to)
 789   (let ((len (length str)))
 790     (if (> from len)
 791         ""
 792       (if (and to (> to len))
 793           (concat (substring str from)
 794                   (company-space-string (- to len)))
 795         (substring str from to)))))
 796
 797 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 798
 799 (defvar company-last-metadata nil)
 800 (make-variable-buffer-local 'company-last-metadata)
 801
 802 (defun company-fetch-metadata ()
 803   (let ((selected (nth company-selection company-candidates)))
 804     (unless (equal selected (car company-last-metadata))
 805       (setq company-last-metadata
 806             (cons selected (funcall company-backend 'meta selected))))
 807     (cdr company-last-metadata)))
 808
 809 (defun company-doc-buffer (&optional string)
 810   (with-current-buffer (get-buffer-create "*Company meta-data*")
 811     (erase-buffer)
 812     (current-buffer)))
 813
 814 (defun company-show-doc-buffer ()
 815   "Temporarily show a buffer with the complete documentation for the selection."
 816   (interactive)
 817   (unless company-mode (error "Company not enabled"))
 818   (when (company-manual-begin)
 819     (save-window-excursion
 820       (let* ((height (window-height))
 821              (row (cdr (posn-col-row (posn-at-point))))
 822              (selected (nth company-selection company-candidates))
 823              (buffer (funcall company-backend 'doc-buffer selected)))
 824         (if (not buffer)
 825             (error "No documentation available.")
 826           (display-buffer buffer)
 827           (and (< (window-height) height)
 828                (< (- (window-height) row 2) company-tooltip-limit)
 829                (recenter (- (window-height) row 2)))
 830           (while (eq 'scroll-other-window
 831                      (key-binding (vector (list (read-event)))))
 832             (scroll-other-window))
 833           (when last-input-event
 834             (clear-this-command-keys t)
 835             (setq unread-command-events (list last-input-event))))))))
 836
 837 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 838
 839 (defvar company-pseudo-tooltip-overlay nil)
 840 (make-variable-buffer-local 'company-pseudo-tooltip-overlay)
 841
 842 (defvar company-tooltip-offset 0)
 843 (make-variable-buffer-local 'company-tooltip-offset)
 844
 845 (defun company-pseudo-tooltip-update-offset (selection num-lines limit)
 846
 847   (decf limit 2)
 848   (setq company-tooltip-offset
 849         (max (min selection company-tooltip-offset)
 850              (- selection -1 limit)))
 851
 852   (when (<= company-tooltip-offset 1)
 853     (incf limit)
 854     (setq company-tooltip-offset 0))
 855
 856   (when (>= company-tooltip-offset (- num-lines limit 1))
 857     (incf limit)
 858     (when (= selection (1- num-lines))
 859       (decf company-tooltip-offset)
 860       (when (<= company-tooltip-offset 1)
 861         (setq company-tooltip-offset 0)
 862         (incf limit))))
 863
 864   limit)
 865
 866 ;;; propertize
 867
 868 (defsubst company-round-tab (arg)
 869   (* (/ (+ arg tab-width) tab-width) tab-width))
 870
 871 (defun company-untabify (str)
 872   (let* ((pieces (split-string str "\t"))
 873          (copy pieces))
 874     (while (cdr copy)
 875       (setcar copy (company-safe-substring
 876                     (car copy) 0 (company-round-tab (string-width (car copy)))))
 877       (pop copy))
 878     (apply 'concat pieces)))
 879
 880 (defun company-fill-propertize (line width selected)
 881   (setq line (company-safe-substring line 0 width))
 882   (add-text-properties 0 width (list 'face 'company-tooltip) line)
 883   (add-text-properties 0 (length company-common)
 884                        (list 'face 'company-tooltip-common) line)
 885   (when selected
 886     (if (and company-search-string
 887              (string-match (regexp-quote company-search-string) line
 888                            (length company-prefix)))
 889         (progn
 890           (add-text-properties (match-beginning 0) (match-end 0)
 891                                '(face company-tooltip-selection) line)
 892           (when (< (match-beginning 0) (length company-common))
 893             (add-text-properties (match-beginning 0) (length company-common)
 894                                  '(face company-tooltip-common-selection)
 895                                  line)))
 896       (add-text-properties 0 width '(face company-tooltip-selection) line)
 897       (add-text-properties 0 (length company-common)
 898                            (list 'face 'company-tooltip-common-selection)
 899                            line)))
 900   line)
 901
 902 ;;; replace
 903
 904 (defun company-buffer-lines (beg end)
 905   (goto-char beg)
 906   (let ((row (cdr (posn-col-row (posn-at-point))))
 907         lines)
 908     (while (and (equal (move-to-window-line (incf row)) row)
 909                 (<= (point) end))
 910       (push (buffer-substring beg (min end (1- (point)))) lines)
 911       (setq beg (point)))
 912     (unless (eq beg end)
 913       (push (buffer-substring beg end) lines))
 914     (nreverse lines)))
 915
 916 (defsubst company-modify-line (old new offset)
 917   (concat (company-safe-substring old 0 offset)
 918           new
 919           (company-safe-substring old (+ offset (length new)))))
 920
 921 (defun company-replacement-string (old lines column nl)
 922   (let (new)
 923     ;; Inject into old lines.
 924     (while old
 925       (push (company-modify-line (pop old) (pop lines) column) new))
 926     ;; Append whole new lines.
 927     (while lines
 928       (push (concat (company-space-string column) (pop lines)) new))
 929     (concat (when nl "\n")
 930             (mapconcat 'identity (nreverse new) "\n")
 931             "\n")))
 932
 933 (defun company-create-lines (column selection limit)
 934
 935   (let ((len company-candidates-length)
 936         lines
 937         width
 938         lines-copy
 939         previous
 940         remainder
 941         new)
 942
 943     ;; Scroll to offset.
 944     (setq limit (company-pseudo-tooltip-update-offset selection len limit))
 945
 946     (when (> company-tooltip-offset 0)
 947       (setq previous (format "...(%d)" company-tooltip-offset)))
 948
 949     (setq remainder (- len limit company-tooltip-offset)
 950           remainder (when (> remainder 0)
 951                       (setq remainder (format "...(%d)" remainder))))
 952
 953     (decf selection company-tooltip-offset)
 954     (setq width (min (length previous) (length remainder))
 955           lines (nthcdr company-tooltip-offset company-candidates)
 956           len (min limit len)
 957           lines-copy lines)
 958
 959     (dotimes (i len)
 960       (setq width (max (length (pop lines-copy)) width)))
 961     (setq width (min width (- (window-width) column)))
 962
 963     (when previous
 964       (push (propertize (company-safe-substring previous 0 width)
 965                         'face 'company-tooltip)
 966             new))
 967
 968     (dotimes (i len)
 969       (push (company-fill-propertize (company-reformat (pop lines))
 970                                      width (equal i selection))
 971             new))
 972
 973     (when remainder
 974       (push (propertize (company-safe-substring remainder 0 width)
 975                         'face 'company-tooltip)
 976             new))
 977
 978     (setq lines (nreverse new))))
 979
 980 ;; show
 981
 982 (defsubst company-pseudo-tooltip-height ()
 983   "Calculate the appropriate tooltip height."
 984   (max 3 (min company-tooltip-limit
 985               (- (window-height) 2
 986                  (count-lines (window-start) (point-at-bol))))))
 987
 988 (defun company-pseudo-tooltip-show (row column selection)
 989   (company-pseudo-tooltip-hide)
 990   (save-excursion
 991
 992     (move-to-column 0)
 993
 994     (let* ((height (company-pseudo-tooltip-height))
 995            (lines (company-create-lines column selection height))
 996            (nl (< (move-to-window-line row) row))
 997            (beg (point))
 998            (end (save-excursion
 999                   (move-to-window-line (+ row height))
1000                   (point)))
1001            (old-string
1002             (mapcar 'company-untabify (company-buffer-lines beg end)))
1003            str)
1004
1005       (setq company-pseudo-tooltip-overlay (make-overlay beg end))
1006
1007       (overlay-put company-pseudo-tooltip-overlay 'company-old old-string)
1008       (overlay-put company-pseudo-tooltip-overlay 'company-column column)
1009       (overlay-put company-pseudo-tooltip-overlay 'company-nl nl)
1010       (overlay-put company-pseudo-tooltip-overlay 'company-before
1011                    (company-replacement-string old-string lines column nl))
1012       (overlay-put company-pseudo-tooltip-overlay 'company-height height)
1013
1014       (overlay-put company-pseudo-tooltip-overlay 'window (selected-window)))))
1015
1016 (defun company-pseudo-tooltip-show-at-point (pos)
1017   (let ((col-row (posn-col-row (posn-at-point pos))))
1018     (company-pseudo-tooltip-show (1+ (cdr col-row)) (car col-row) company-selection)))
1019
1020 (defun company-pseudo-tooltip-edit (lines selection)
1021   (let* ((old-string (overlay-get company-pseudo-tooltip-overlay 'company-old))
1022          (column (overlay-get company-pseudo-tooltip-overlay 'company-column))
1023          (nl (overlay-get company-pseudo-tooltip-overlay 'company-nl))
1024          (height (overlay-get company-pseudo-tooltip-overlay 'company-height))
1025          (lines (company-create-lines column selection height)))
1026     (overlay-put company-pseudo-tooltip-overlay 'company-before
1027                  (company-replacement-string old-string lines column nl))))
1028
1029 (defun company-pseudo-tooltip-hide ()
1030   (when company-pseudo-tooltip-overlay
1031     (delete-overlay company-pseudo-tooltip-overlay)
1032     (setq company-pseudo-tooltip-overlay nil)))
1033
1034 (defun company-pseudo-tooltip-hide-temporarily ()
1035   (when (overlayp company-pseudo-tooltip-overlay)
1036     (overlay-put company-pseudo-tooltip-overlay 'invisible nil)
1037     (overlay-put company-pseudo-tooltip-overlay 'before-string nil)))
1038
1039 (defun company-pseudo-tooltip-unhide ()
1040   (when company-pseudo-tooltip-overlay
1041     (overlay-put company-pseudo-tooltip-overlay 'invisible t)
1042     (overlay-put company-pseudo-tooltip-overlay 'before-string
1043                  (overlay-get company-pseudo-tooltip-overlay 'company-before))
1044     (overlay-put company-pseudo-tooltip-overlay 'window (selected-window))))
1045
1046 (defun company-pseudo-tooltip-frontend (command)
1047   "A `company-mode' front-end similar to a tool-tip but based on overlays."
1048   (case command
1049     ('pre-command (company-pseudo-tooltip-hide-temporarily))
1050     ('post-command
1051      (unless (and (overlayp company-pseudo-tooltip-overlay)
1052                   (equal (overlay-get company-pseudo-tooltip-overlay
1053                                       'company-height)
1054                          (company-pseudo-tooltip-height)))
1055        ;; Redraw needed.
1056        (company-pseudo-tooltip-show-at-point (- (point)
1057                                                 (length company-prefix))))
1058      (company-pseudo-tooltip-unhide))
1059     ('hide (company-pseudo-tooltip-hide)
1060            (setq company-tooltip-offset 0))
1061     ('update (when (overlayp company-pseudo-tooltip-overlay)
1062                (company-pseudo-tooltip-edit company-candidates
1063                                             company-selection)))))
1064
1065 (defun company-pseudo-tooltip-unless-just-one-frontend (command)
1066   "`company-pseudo-tooltip-frontend', but not shown for single candidates."
1067   (unless (and (eq command 'post-command)
1068                (not (cdr company-candidates)))
1069     (company-pseudo-tooltip-frontend command)))
1070
1071 ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1072
1073 (defvar company-preview-overlay nil)
1074 (make-variable-buffer-local 'company-preview-overlay)
1075
1076 (defun company-preview-show-at-point (pos)
1077   (company-preview-hide)
1078
1079   (setq company-preview-overlay (make-overlay pos pos))
1080
1081   (let ((completion (company-strip-prefix (nth company-selection
1082                                                company-candidates))))
1083     (and (equal pos (point))
1084          (not (equal completion ""))
1085          (add-text-properties 0 1 '(cursor t) completion))
1086
1087     (setq completion (propertize completion 'face 'company-preview))
1088     (add-text-properties 0 (- (length company-common) (length company-prefix))
1089                          '(face company-preview-common) completion)
1090
1091     (overlay-put company-preview-overlay 'after-string completion)
1092     (overlay-put company-preview-overlay 'window (selected-window))))
1093
1094 (defun company-preview-hide ()
1095   (when company-preview-overlay
1096     (delete-overlay company-preview-overlay)
1097     (setq company-preview-overlay nil)))
1098
1099 (defun company-preview-frontend (command)
1100   "A `company-mode' front-end showing the selection as if it had been inserted."
1101   (case command
1102     ('pre-command (company-preview-hide))
1103     ('post-command (company-preview-show-at-point (point)))
1104     ('hide (company-preview-hide))))
1105
1106 (defun company-preview-if-just-one-frontend (command)
1107   "`company-preview-frontend', but only shown for single candidates."
1108   (unless (and (eq command 'post-command)
1109                (cdr company-candidates))
1110     (company-preview-frontend command)))
1111
1112 ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1113
1114 (defvar company-echo-last-msg nil)
1115 (make-variable-buffer-local 'company-echo-last-msg)
1116
1117 (defvar company-echo-timer nil)
1118
1119 (defvar company-echo-delay .1)
1120
1121 (defun company-echo-show (&optional getter)
1122   (when getter
1123     (setq company-echo-last-msg (funcall getter)))
1124   (let ((message-log-max nil))
1125     (if company-echo-last-msg
1126         (message "%s" company-echo-last-msg)
1127       (message ""))))
1128
1129 (defsubst company-echo-show-soon (&optional getter)
1130   (when company-echo-timer
1131     (cancel-timer company-echo-timer))
1132   (setq company-echo-timer (run-with-timer company-echo-delay nil
1133                                            'company-echo-show getter)))
1134
1135 (defun company-echo-format ()
1136
1137   (let ((limit (window-width (minibuffer-window)))
1138         (len -1)
1139         ;; Roll to selection.
1140         (candidates (nthcdr company-selection company-candidates))
1141         comp msg)
1142
1143     (while candidates
1144       (setq comp (company-reformat (pop candidates))
1145             len (+ len 1 (length comp)))
1146       (if (>= len limit)
1147           (setq candidates nil)
1148         (setq comp (propertize comp 'face 'company-echo))
1149         (add-text-properties 0 (length company-common)
1150                              '(face company-echo-common) comp)
1151         (push comp msg)))
1152
1153     (mapconcat 'identity (nreverse msg) " ")))
1154
1155 (defun company-echo-hide ()
1156   (when company-echo-timer
1157     (cancel-timer company-echo-timer))
1158   (setq company-echo-last-msg "")
1159   (company-echo-show))
1160
1161 (defun company-echo-frontend (command)
1162   "A `company-mode' front-end showing the candidates in the echo area."
1163   (case command
1164     ('pre-command (company-echo-show-soon))
1165     ('post-command (company-echo-show-soon 'company-echo-format))
1166     ('hide (company-echo-hide))))
1167
1168 (defun company-echo-metadata-frontend (command)
1169   "A `company-mode' front-end showing the documentation in the echo area."
1170   (case command
1171     ('pre-command (company-echo-show-soon))
1172     ('post-command (company-echo-show-soon 'company-fetch-metadata))
1173     ('hide (company-echo-hide))))
1174
1175 (provide 'company)
1176 ;;; company.el ends here