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