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