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: 0.3.1
   7 ;; Keywords: abbrev, convenience, matchis
   8 ;; URL: http://nschum.de/src/emacs/company/
   9 ;; Compatibility: GNU Emacs 22.x, GNU Emacs 23.x
  10 ;;
  11 ;; This file is NOT part of GNU Emacs.
  12 ;;
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License
  15 ;; as published by the Free Software Foundation; either version 2
  16 ;; of the License, or (at your option) any later version.
  17 ;;
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25 ;;
  26 ;;; Commentary:
  27 ;;
  28 ;; Company is a modular completion mechanism.  Modules for retrieving completion
  29 ;; candidates are called back-ends, modules for displaying them are front-ends.
  30 ;;
  31 ;; Company comes with many back-ends, e.g. `company-elisp'.  These are
  32 ;; distributed in individual files and can be used individually.
  33 ;;
  34 ;; Place company.el and the back-ends you want to use in a directory and add the
  35 ;; following to your .emacs:
  36 ;; (add-to-list 'load-path "/path/to/company")
  37 ;; (autoload 'company-mode "company" nil t)
  38 ;;
  39 ;; Enable company-mode with M-x company-mode.  For further information look at
  40 ;; the documentation for `company-mode' (C-h f company-mode RET)
  41 ;;
  42 ;; If you want to start a specific back-end, call it interactively or use
  43 ;; `company-begin-backend'.  For example:
  44 ;; M-x company-abbrev will prompt for and insert an abbrev.
  45 ;;
  46 ;; To write your own back-end, look at the documentation for `company-backends'.
  47 ;; Here is a simple example completing "foo":
  48 ;;
  49 ;; (defun company-my-backend (command &optional arg &rest ignored)
  50 ;;   (case command
  51 ;;     ('prefix (when (looking-back "foo\\>")
  52 ;;                (match-string 0)))
  53 ;;     ('candidates (list "foobar" "foobaz" "foobarbaz"))
  54 ;;     ('meta (format "This value is named %s" arg))))
  55 ;;
  56 ;; Sometimes it is a good idea to mix two back-ends together, for example to
  57 ;; enrich gtags with dabbrev text (to emulate local variables):
  58 ;;
  59 ;; (defun gtags-gtags-dabbrev-backend (command &optional arg &rest ignored)
  60 ;;   (case command
  61 ;;     (prefix (company-gtags 'prefix))
  62 ;;     (candidates (append (company-gtags 'candidates arg)
  63 ;;                         (company-dabbrev 'candidates arg)))))
  64 ;;
  65 ;; Known Issues:
  66 ;; When point is at the very end of the buffer, the pseudo-tooltip appears very
  67 ;; wrong, unless company is allowed to temporarily insert a fake newline.
  68 ;; This behavior is enabled by `company-end-of-buffer-workaround'.
  69 ;;
  70 ;;; Change Log:
  71 ;;
  72 ;;    Added back-end `company-dabbrev-code' for generic code.
  73 ;;    Fixed `company-begin-with'.
  74 ;;
  75 ;; 2009-04-15 (0.3.1)
  76 ;;    Added 'stop prefix to prevent dabbrev from completing inside of symbols.
  77 ;;    Fixed issues with tabbar-mode and line-spacing.
  78 ;;    Performance enhancements.
  79 ;;
  80 ;; 2009-04-12 (0.3)
  81 ;;    Added `company-begin-commands' option.
  82 ;;    Added abbrev, tempo and Xcode back-ends.
  83 ;;    Back-ends are now interactive.  You can start them with M-x backend-name.
  84 ;;    Added `company-begin-with' for starting company from elisp-code.
  85 ;;    Added hooks.
  86 ;;    Added `company-require-match' and `company-auto-complete' options.
  87 ;;
  88 ;; 2009-04-05 (0.2.1)
  89 ;;    Improved Emacs Lisp back-end behavior for local variables.
  90 ;;    Added `company-elisp-detect-function-context' option.
  91 ;;    The mouse can now be used for selection.
  92 ;;
  93 ;; 2009-03-22 (0.2)
  94 ;;    Added `company-show-location'.
  95 ;;    Added etags back-end.
  96 ;;    Added work-around for end-of-buffer bug.
  97 ;;    Added `company-filter-candidates'.
  98 ;;    More local Lisp variables are now included in the candidates.
  99 ;;
 100 ;; 2009-03-21 (0.1.5)
 101 ;;    Fixed elisp documentation buffer always showing the same doc.
 102 ;;    Added `company-echo-strip-common-frontend'.
 103 ;;    Added `company-show-numbers' option and M-0 ... M-9 default bindings.
 104 ;;    Don't hide the echo message if it isn't shown.
 105 ;;
 106 ;; 2009-03-20 (0.1)
 107 ;;    Initial release.
 108 ;;
 109 ;;; Code:
 110
 111 (eval-when-compile (require 'cl))
 112
 113 (add-to-list 'debug-ignored-errors "^.* frontend cannot be used twice$")
 114 (add-to-list 'debug-ignored-errors "^Echo area cannot be used twice$")
 115 (add-to-list 'debug-ignored-errors "^No \\(document\\|loc\\)ation available$")
 116 (add-to-list 'debug-ignored-errors "^Company not ")
 117 (add-to-list 'debug-ignored-errors "^No candidate number ")
 118 (add-to-list 'debug-ignored-errors "^Cannot complete at point$")
 119
 120 (defgroup company nil
 121   "Extensible inline text completion mechanism"
 122   :group 'abbrev
 123   :group 'convenience
 124   :group 'maching)
 125
 126 (defface company-tooltip
 127   '((t :background "yellow"
 128        :foreground "black"))
 129   "*Face used for the tool tip."
 130   :group 'company)
 131
 132 (defface company-tooltip-selection
 133   '((default :inherit company-tooltip)
 134     (((class color) (min-colors 88)) (:background "orange1"))
 135     (t (:background "green")))
 136   "*Face used for the selection in the tool tip."
 137   :group 'company)
 138
 139 (defface company-tooltip-mouse
 140   '((default :inherit highlight))
 141   "*Face used for the tool tip item under the mouse."
 142   :group 'company)
 143
 144 (defface company-tooltip-common
 145   '((t :inherit company-tooltip
 146        :foreground "red"))
 147   "*Face used for the common completion in the tool tip."
 148   :group 'company)
 149
 150 (defface company-tooltip-common-selection
 151   '((t :inherit company-tooltip-selection
 152        :foreground "red"))
 153   "*Face used for the selected common completion in the tool tip."
 154   :group 'company)
 155
 156 (defcustom company-tooltip-limit 10
 157   "*The maximum number of candidates in the tool tip"
 158   :group 'company
 159   :type 'integer)
 160
 161 (defface company-preview
 162   '((t :background "blue4"
 163        :foreground "wheat"))
 164   "*Face used for the completion preview."
 165   :group 'company)
 166
 167 (defface company-preview-common
 168   '((t :inherit company-preview
 169        :foreground "red"))
 170   "*Face used for the common part of the completion preview."
 171   :group 'company)
 172
 173 (defface company-preview-search
 174   '((t :inherit company-preview
 175        :background "blue1"))
 176   "*Face used for the search string in the completion preview."
 177   :group 'company)
 178
 179 (defface company-echo nil
 180   "*Face used for completions in the echo area."
 181   :group 'company)
 182
 183 (defface company-echo-common
 184   '((((background dark)) (:foreground "firebrick1"))
 185     (((background light)) (:background "firebrick4")))
 186   "*Face used for the common part of completions in the echo area."
 187   :group 'company)
 188
 189 (defun company-frontends-set (variable value)
 190   ;; uniquify
 191   (let ((remainder value))
 192     (setcdr remainder (delq (car remainder) (cdr remainder))))
 193   (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
 194        (memq 'company-pseudo-tooltip-frontend value)
 195        (error "Pseudo tooltip frontend cannot be used twice"))
 196   (and (memq 'company-preview-if-just-one-frontend value)
 197        (memq 'company-preview-frontend value)
 198        (error "Preview frontend cannot be used twice"))
 199   (and (memq 'company-echo value)
 200        (memq 'company-echo-metadata-frontend value)
 201        (error "Echo area cannot be used twice"))
 202   ;; preview must come last
 203   (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend))
 204     (when (memq f value)
 205       (setq value (append (delq f value) (list f)))))
 206   (set variable value))
 207
 208 (defcustom company-frontends '(company-pseudo-tooltip-unless-just-one-frontend
 209                                company-preview-frontend
 210                                company-echo-metadata-frontend)
 211   "*The list of active front-ends (visualizations).
 212 Each front-end is a function that takes one argument.  It is called with
 213 one of the following arguments:
 214
 215 'show: When the visualization should start.
 216
 217 'hide: When the visualization should end.
 218
 219 'update: When the data has been updated.
 220
 221 'pre-command: Before every command that is executed while the
 222 visualization is active.
 223
 224 'post-command: After every command that is executed while the
 225 visualization is active.
 226
 227 The visualized data is stored in `company-prefix', `company-candidates',
 228 `company-common', `company-selection', `company-point' and
 229 `company-search-string'."
 230   :set 'company-frontends-set
 231   :group 'company
 232   :type '(repeat (choice (const :tag "echo" company-echo-frontend)
 233                          (const :tag "echo, strip common"
 234                                 company-echo-strip-common-frontend)
 235                          (const :tag "show echo meta-data in echo"
 236                                 company-echo-metadata-frontend)
 237                          (const :tag "pseudo tooltip"
 238                                 company-pseudo-tooltip-frontend)
 239                          (const :tag "pseudo tooltip, multiple only"
 240                                 company-pseudo-tooltip-unless-just-one-frontend)
 241                          (const :tag "preview" company-preview-frontend)
 242                          (const :tag "preview, unique only"
 243                                 company-preview-if-just-one-frontend)
 244                          (function :tag "custom function" nil))))
 245
 246 (defvar company-safe-backends
 247   '(company-abbrev company-css company-dabbrev-code company-dabbrev
 248     company-elisp company-etags company-files company-gtags company-ispell
 249     company-nxml company-oddmuse company-semantic company-tempo company-xcode))
 250 (put 'company-safe-backends 'risky-local-variable t)
 251
 252 (defun company-safe-backends-p (backends)
 253   (and (consp backends)
 254        (not (dolist (backend backends)
 255               (unless (memq backend company-safe-backends)
 256                 (return t))))))
 257
 258 (defcustom company-backends '(company-elisp company-nxml company-css
 259                               company-semantic company-xcode company-gtags
 260                               company-etags company-oddmuse company-files
 261                               company-dabbrev-code company-dabbrev)
 262   "*The list of active back-ends (completion engines).
 263 Each back-end is a function that takes a variable number of arguments.
 264 The first argument is the command requested from the back-end.  It is one
 265 of the following:
 266
 267 'prefix: The back-end should return the text to be completed.  It must be
 268 text immediately before `point'.  Returning nil passes control to the next
 269 back-end.  The function should return 'stop if it should complete but cannot
 270 \(e.g. if it is in the middle of a string\).
 271
 272 'candidates: The second argument is the prefix to be completed.  The
 273 return value should be a list of candidates that start with the prefix.
 274
 275 Optional commands:
 276
 277 'sorted: The back-end may return t here to indicate that the candidates
 278 are sorted and will not need to be sorted again.
 279
 280 'duplicates: If non-nil, company will take care of removing duplicates
 281 from the list.
 282
 283 'no-cache: Usually company doesn't ask for candidates again as completion
 284 progresses, unless the back-end returns t for this command.  The second
 285 argument is the latest prefix.
 286
 287 'meta: The second argument is a completion candidate.  The back-end should
 288 return a (short) documentation string for it.
 289
 290 'doc-buffer: The second argument is a completion candidate.  The back-end should
 291 create a buffer (preferably with `company-doc-buffer'), fill it with
 292 documentation and return it.
 293
 294 'location: The second argument is a completion candidate.  The back-end can
 295 return the cons of buffer and buffer location, or of file and line
 296 number where the completion candidate was defined.
 297
 298 'require-match: If this value is t, the user is not allowed to enter anything
 299 not offering as a candidate.  Use with care!  The default value nil gives the
 300 user that choice with `company-require-match'.  Return value 'never overrides
 301 that option the other way around.
 302
 303 The back-end should return nil for all commands it does not support or
 304 does not know about.  It should also be callable interactively and use
 305 `company-begin-backend' to start itself in that case."
 306   :group 'company
 307   :type '(repeat (function :tag "function" nil)))
 308
 309 (put 'company-backends 'safe-local-variable 'company-safe-backend-p)
 310
 311 (defcustom company-completion-started-hook nil
 312   "*Hook run when company starts completing.
 313 The hook is called with one argument that is non-nil if the completion was
 314 started manually."
 315   :group 'company
 316   :type 'hook)
 317
 318 (defcustom company-completion-cancelled-hook nil
 319   "*Hook run when company cancels completing.
 320 The hook is called with one argument that is non-nil if the completion was
 321 aborted manually."
 322   :group 'company
 323   :type 'hook)
 324
 325 (defcustom company-completion-finished-hook nil
 326   "*Hook run when company successfully completes.
 327 The hook is called with the selected candidate as an argument."
 328   :group 'company
 329   :type 'hook)
 330
 331 (defcustom company-minimum-prefix-length 3
 332   "*The minimum prefix length for automatic completion."
 333   :group 'company
 334   :type '(integer :tag "prefix length"))
 335
 336 (defcustom company-require-match 'company-explicit-action-p
 337   "*If enabled, disallow non-matching input.
 338 This can be a function do determine if a match is required.
 339
 340 This can be overridden by the back-end, if it returns t or 'never to
 341 'require-match.  `company-auto-complete' also takes precedence over this."
 342   :group 'company
 343   :type '(choice (const :tag "Off" nil)
 344                  (function :tag "Predicate function")
 345                  (const :tag "On, if user interaction took place"
 346                         'company-explicit-action-p)
 347                  (const :tag "On" t)))
 348
 349 (defcustom company-auto-complete 'company-explicit-action-p
 350   "Determines when to auto-complete.
 351 If this is enabled, all characters from `company-auto-complete-chars' complete
 352 the selected completion.  This can also be a function."
 353   :group 'company
 354   :type '(choice (const :tag "Off" nil)
 355                  (function :tag "Predicate function")
 356                  (const :tag "On, if user interaction took place"
 357                         'company-explicit-action-p)
 358                  (const :tag "On" t)))
 359
 360 (defcustom company-auto-complete-chars '(?\  ?\( ?\) ?. ?\" ?$ ?\' ?< ?| ?!)
 361   "Determines which characters trigger an automatic completion.
 362 See `company-auto-complete'.  If this is a string, each string character causes
 363 completion.  If it is a list of syntax description characters (see
 364 `modify-syntax-entry'), all characters with that syntax auto-complete.
 365
 366 This can also be a function, which is called with the new input and should
 367 return non-nil if company should auto-complete.
 368
 369 A character that is part of a valid candidate never starts auto-completion."
 370   :group 'company
 371   :type '(choice (string :tag "Characters")
 372                  (set :tag "Syntax"
 373                       (const :tag "Whitespace" ?\ )
 374                       (const :tag "Symbol" ?_)
 375                       (const :tag "Opening parentheses" ?\()
 376                       (const :tag "Closing parentheses" ?\))
 377                       (const :tag "Word constituent" ?w)
 378                       (const :tag "Punctuation." ?.)
 379                       (const :tag "String quote." ?\")
 380                       (const :tag "Paired delimiter." ?$)
 381                       (const :tag "Expression quote or prefix operator." ?\')
 382                       (const :tag "Comment starter." ?<)
 383                       (const :tag "Comment ender." ?>)
 384                       (const :tag "Character-quote." ?/)
 385                       (const :tag "Generic string fence." ?|)
 386                       (const :tag "Generic comment fence." ?!))
 387                  (function :tag "Predicate function")))
 388
 389 (defcustom company-idle-delay .7
 390   "*The idle delay in seconds until automatic completions starts.
 391 A value of nil means never complete automatically, t means complete
 392 immediately when a prefix of `company-minimum-prefix-length' is reached."
 393   :group 'company
 394   :type '(choice (const :tag "never (nil)" nil)
 395                  (const :tag "immediate (t)" t)
 396                  (number :tag "seconds")))
 397
 398 (defcustom company-begin-commands t
 399   "*A list of commands following which company will start completing.
 400 If this is t, it will complete after any command.  See `company-idle-delay'.
 401
 402 Alternatively any command with a non-nil 'company-begin property is treated as
 403 if it was on this list."
 404   :group 'company
 405   :type '(choice (const :tag "Any command" t)
 406                  (const :tag "Self insert command" '(self-insert-command))
 407                  (repeat :tag "Commands" function)))
 408
 409 (defcustom company-show-numbers nil
 410   "*If enabled, show quick-access numbers for the first ten candidates."
 411   :group 'company
 412   :type '(choice (const :tag "off" nil)
 413                  (const :tag "on" t)))
 414
 415 (defvar company-end-of-buffer-workaround t
 416   "*Work around a visualization bug when completing at the end of the buffer.
 417 The work-around consists of adding a newline.")
 418
 419 ;;; mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 420
 421 (defvar company-mode-map (make-sparse-keymap)
 422   "Keymap used by `company-mode'.")
 423
 424 (defvar company-active-map
 425   (let ((keymap (make-sparse-keymap)))
 426     (define-key keymap "\e\e\e" 'company-abort)
 427     (define-key keymap "\C-g" 'company-abort)
 428     (define-key keymap (kbd "M-n") 'company-select-next)
 429     (define-key keymap (kbd "M-p") 'company-select-previous)
 430     (define-key keymap (kbd "<down>") 'company-select-next)
 431     (define-key keymap (kbd "<up>") 'company-select-previous)
 432     (define-key keymap [down-mouse-1] 'ignore)
 433     (define-key keymap [down-mouse-3] 'ignore)
 434     (define-key keymap [mouse-1] 'company-complete-mouse)
 435     (define-key keymap [mouse-3] 'company-select-mouse)
 436     (define-key keymap [up-mouse-1] 'ignore)
 437     (define-key keymap [up-mouse-3] 'ignore)
 438     (define-key keymap "\C-m" 'company-complete-selection)
 439     (define-key keymap "\t" 'company-complete-common)
 440     (define-key keymap (kbd "<f1>") 'company-show-doc-buffer)
 441     (define-key keymap "\C-w" 'company-show-location)
 442     (define-key keymap "\C-s" 'company-search-candidates)
 443     (define-key keymap "\C-\M-s" 'company-filter-candidates)
 444     (dotimes (i 10)
 445       (define-key keymap (vector (+ (aref (kbd "M-0") 0) i))
 446         `(lambda () (interactive) (company-complete-number ,i))))
 447
 448     keymap)
 449   "Keymap that is enabled during an active completion.")
 450
 451 (defun company-init-backend (backend)
 452   (when (symbolp backend)
 453     (unless (fboundp backend)
 454       (ignore-errors (require backend nil t)))
 455     (if (and (fboundp backend)
 456              (ignore-errors (funcall backend 'init) t))
 457         (put backend 'company-init t)
 458       (message "Company back-end '%s' could not be initialized"
 459                backend))))
 460
 461 ;;;###autoload
 462 (define-minor-mode company-mode
 463   "\"complete anything\"; in in-buffer completion framework.
 464 Completion starts automatically, depending on the values
 465 `company-idle-delay' and `company-minimum-prefix-length'.
 466
 467 Completion can be controlled with the commands:
 468 `company-complete-common', `company-complete-selection', `company-complete',
 469 `company-select-next', `company-select-previous'.  If these commands are
 470 called before `company-idle-delay', completion will also start.
 471
 472 Completions can be searched with `company-search-candidates' or
 473 `company-filter-candidates'.  These can be used while completion is
 474 inactive, as well.
 475
 476 The completion data is retrieved using `company-backends' and displayed using
 477 `company-frontends'.  If you want to start a specific back-end, call it
 478 interactively or use `company-begin-backend'.
 479
 480 regular keymap (`company-mode-map'):
 481
 482 \\{company-mode-map}
 483 keymap during active completions (`company-active-map'):
 484
 485 \\{company-active-map}"
 486   nil " comp" company-mode-map
 487   (if company-mode
 488       (progn
 489         (add-hook 'pre-command-hook 'company-pre-command nil t)
 490         (add-hook 'post-command-hook 'company-post-command nil t)
 491         (mapc 'company-init-backend company-backends))
 492     (remove-hook 'pre-command-hook 'company-pre-command t)
 493     (remove-hook 'post-command-hook 'company-post-command t)
 494     (company-cancel)
 495     (kill-local-variable 'company-point)))
 496
 497 (defsubst company-assert-enabled ()
 498   (unless company-mode
 499     (company-uninstall-map)
 500     (error "Company not enabled")))
 501
 502 ;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 503
 504 (defvar company-overriding-keymap-bound nil)
 505 (make-variable-buffer-local 'company-overriding-keymap-bound)
 506
 507 (defvar company-old-keymap nil)
 508 (make-variable-buffer-local 'company-old-keymap)
 509
 510 (defvar company-my-keymap nil)
 511 (make-variable-buffer-local 'company-my-keymap)
 512
 513 (defsubst company-enable-overriding-keymap (keymap)
 514   (setq company-my-keymap keymap)
 515   (when company-overriding-keymap-bound
 516     (company-uninstall-map)))
 517
 518 (defun company-install-map ()
 519   (unless (or company-overriding-keymap-bound
 520               (null company-my-keymap))
 521     (setq company-old-keymap overriding-terminal-local-map
 522           overriding-terminal-local-map company-my-keymap
 523           company-overriding-keymap-bound t)))
 524
 525 (defun company-uninstall-map ()
 526   (when (eq overriding-terminal-local-map company-my-keymap)
 527     (setq overriding-terminal-local-map company-old-keymap
 528           company-overriding-keymap-bound nil)))
 529
 530 ;; Hack:
 531 ;; Emacs calculates the active keymaps before reading the event.  That means we
 532 ;; cannot change the keymap from a timer.  So we send a bogus command.
 533 (defun company-ignore ()
 534   (interactive))
 535
 536 (global-set-key '[31415926] 'company-ignore)
 537
 538 (defun company-input-noop ()
 539   (push 31415926 unread-command-events))
 540
 541 ;;; backends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 542
 543 (defun company-grab (regexp &optional expression limit)
 544   (when (looking-back regexp limit)
 545     (or (match-string-no-properties (or expression 0)) "")))
 546
 547 (defun company-grab-line (regexp &optional expression)
 548   (company-grab regexp expression (point-at-bol)))
 549
 550 (defun company-grab-symbol ()
 551   (if (looking-at "\\_>")
 552       (buffer-substring (point) (save-excursion (skip-syntax-backward "w_")
 553                                                 (point)))
 554     (unless (and (char-after) (memq (char-syntax (char-after)) '(?w ?_)))
 555       "")))
 556
 557 (defun company-grab-word ()
 558   (if (looking-at "\\>")
 559       (buffer-substring (point) (save-excursion (skip-syntax-backward "w")
 560                                                 (point)))
 561     (unless (and (char-after) (eq (char-syntax (char-after)) ?w))
 562       "")))
 563
 564 (defun company-in-string-or-comment ()
 565   (let ((ppss (syntax-ppss)))
 566     (or (nth 3 ppss) (nth 4 ppss) (nth 7 ppss))))
 567
 568 (defun company-call-backend (&rest args)
 569   (apply 'company-backend args))
 570
 571 ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 572
 573 (defvar company-backend nil)
 574 (make-variable-buffer-local 'company-backend)
 575
 576 (defvar company-prefix nil)
 577 (make-variable-buffer-local 'company-prefix)
 578
 579 (defvar company-candidates nil)
 580 (make-variable-buffer-local 'company-candidates)
 581
 582 (defvar company-candidates-length nil)
 583 (make-variable-buffer-local 'company-candidates-length)
 584
 585 (defvar company-candidates-cache nil)
 586 (make-variable-buffer-local 'company-candidates-cache)
 587
 588 (defvar company-candidates-predicate nil)
 589 (make-variable-buffer-local 'company-candidates-predicate)
 590
 591 (defvar company-common nil)
 592 (make-variable-buffer-local 'company-common)
 593
 594 (defvar company-selection 0)
 595 (make-variable-buffer-local 'company-selection)
 596
 597 (defvar company-selection-changed nil)
 598 (make-variable-buffer-local 'company-selection-changed)
 599
 600 (defvar company--explicit-action nil
 601   "Non-nil, if explicit completion took place.")
 602 (make-variable-buffer-local 'company--explicit-action)
 603
 604 (defvar company--this-command nil)
 605
 606 (defvar company-point nil)
 607 (make-variable-buffer-local 'company-point)
 608
 609 (defvar company-timer nil)
 610
 611 (defvar company-added-newline nil)
 612 (make-variable-buffer-local 'company-added-newline)
 613
 614 (defsubst company-strip-prefix (str)
 615   (substring str (length company-prefix)))
 616
 617 (defun company-explicit-action-p ()
 618   "Return whether explicit completion action was taken by the user."
 619   (or company--explicit-action
 620       company-selection-changed))
 621
 622 (defsubst company-reformat (candidate)
 623   ;; company-ispell needs this, because the results are always lower-case
 624   ;; It's mory efficient to fix it only when they are displayed.
 625   (concat company-prefix (substring candidate (length company-prefix))))
 626
 627 (defun company--should-complete ()
 628   (and (not (or buffer-read-only overriding-terminal-local-map
 629                 overriding-local-map))
 630        (eq company-idle-delay t)
 631        (or (eq t company-begin-commands)
 632            (memq company--this-command company-begin-commands)
 633            (and (symbolp this-command) (get this-command 'company-begin)))
 634        (not (and transient-mark-mode mark-active))))
 635
 636 (defsubst company-call-frontends (command)
 637   (dolist (frontend company-frontends)
 638     (condition-case err
 639         (funcall frontend command)
 640       (error (error "Company: Front-end %s error \"%s\" on command %s"
 641                     frontend (error-message-string err) command)))))
 642
 643 (defsubst company-set-selection (selection &optional force-update)
 644   (setq selection (max 0 (min (1- company-candidates-length) selection)))
 645   (when (or force-update (not (equal selection company-selection)))
 646     (setq company-selection selection
 647           company-selection-changed t)
 648     (company-call-frontends 'update)))
 649
 650 (defun company-apply-predicate (candidates predicate)
 651   (let (new)
 652     (dolist (c candidates)
 653       (when (funcall predicate c)
 654         (push c new)))
 655     (nreverse new)))
 656
 657 (defun company-update-candidates (candidates)
 658   (setq company-candidates-length (length candidates))
 659   (if (> company-selection 0)
 660       ;; Try to restore the selection
 661       (let ((selected (nth company-selection company-candidates)))
 662         (setq company-selection 0
 663               company-candidates candidates)
 664         (when selected
 665           (while (and candidates (string< (pop candidates) selected))
 666             (incf company-selection))
 667           (unless candidates
 668             ;; Make sure selection isn't out of bounds.
 669             (setq company-selection (min (1- company-candidates-length)
 670                                          company-selection)))))
 671     (setq company-selection 0
 672           company-candidates candidates))
 673   ;; Save in cache:
 674   (push (cons company-prefix company-candidates) company-candidates-cache)
 675   ;; Calculate common.
 676   (let ((completion-ignore-case (company-call-backend 'ignore-case)))
 677     (setq company-common (try-completion company-prefix company-candidates)))
 678   (when (eq company-common t)
 679     (setq company-candidates nil)))
 680
 681 (defun company-calculate-candidates (prefix)
 682   (let ((candidates
 683          (or (cdr (assoc prefix company-candidates-cache))
 684              (when company-candidates-cache
 685                (let ((len (length prefix))
 686                      (completion-ignore-case (company-call-backend
 687                                               'ignore-case))
 688                      prev)
 689                  (dotimes (i (1+ len))
 690                    (when (setq prev (cdr (assoc (substring prefix 0 (- len i))
 691                                                 company-candidates-cache)))
 692                      (return (all-completions prefix prev))))))
 693              (let ((c (company-call-backend 'candidates prefix)))
 694                (when company-candidates-predicate
 695                  (setq c (company-apply-predicate
 696                           c company-candidates-predicate)))
 697                (unless (company-call-backend 'sorted)
 698                  (setq c (sort c 'string<)))
 699                (when (company-call-backend 'duplicates)
 700                  ;; strip duplicates
 701                  (let ((c2 c))
 702                    (while c2
 703                      (setcdr c2 (progn (while (equal (pop c2) (car c2)))
 704                                        c2)))))
 705                c))))
 706     (if (or (cdr candidates)
 707             (not (equal (car candidates) prefix)))
 708         ;; Don't start when already completed and unique.
 709         candidates
 710       ;; Not the right place? maybe when setting?
 711       (and company-candidates t))))
 712
 713 (defun company-idle-begin (buf win tick pos)
 714   (and company-mode
 715        (eq buf (current-buffer))
 716        (eq win (selected-window))
 717        (eq tick (buffer-chars-modified-tick))
 718        (eq pos (point))
 719        (not company-candidates)
 720        (not (equal (point) company-point))
 721        (let ((company-idle-delay t))
 722          (company-begin)
 723          (when company-candidates
 724            (company-input-noop)
 725            (company-post-command)))))
 726
 727 (defun company-manual-begin ()
 728   (interactive)
 729   (company-assert-enabled)
 730   (and company-mode
 731        (not company-candidates)
 732        (let ((company-idle-delay t)
 733              (company-minimum-prefix-length 0)
 734              (company-begin-commands t))
 735          (setq company--explicit-action t)
 736          (company-begin)))
 737   ;; Return non-nil if active.
 738   company-candidates)
 739
 740 (defsubst company-incremental-p (old-prefix new-prefix)
 741   (and (> (length new-prefix) (length old-prefix))
 742        (equal old-prefix (substring new-prefix 0 (length old-prefix)))))
 743
 744 (defun company-require-match-p ()
 745   (let ((backend-value (company-call-backend 'require-match)))
 746     (or (eq backend-value t)
 747         (and (if (functionp company-require-match)
 748                  (funcall company-require-match)
 749                (eq company-require-match t))
 750              (not (eq backend-value 'never))))))
 751
 752 (defun company-punctuation-p (input)
 753   "Return non-nil, if input starts with punctuation or parentheses."
 754   (memq (char-syntax (string-to-char input)) '(?. ?\( ?\))))
 755
 756 (defun company-auto-complete-p (beg end)
 757   "Return non-nil, if input starts with punctuation or parentheses."
 758   (and (> end beg)
 759        (if (functionp company-auto-complete)
 760            (funcall company-auto-complete)
 761          company-auto-complete)
 762        (if (functionp company-auto-complete-chars)
 763            (funcall company-auto-complete-chars (buffer-substring beg end))
 764          (if (consp company-auto-complete-chars)
 765              (memq (char-syntax (char-after beg)) company-auto-complete-chars)
 766            (string-match (buffer-substring beg (1+ beg))
 767                          company-auto-complete-chars)))))
 768
 769 (defun company-continue ()
 770   (when (company-call-backend 'no-cache company-prefix)
 771     ;; Don't complete existing candidates, fetch new ones.
 772     (setq company-candidates-cache nil))
 773   (let ((new-prefix (company-call-backend 'prefix)))
 774     (if (= (- (point) (length new-prefix))
 775            (- company-point (length company-prefix)))
 776         (unless (or (equal company-prefix new-prefix)
 777                     (let ((c (company-calculate-candidates new-prefix)))
 778                       ;; t means complete/unique.
 779                       (if (eq c t)
 780                           (progn (company-cancel new-prefix) t)
 781                         (when (consp c)
 782                           (setq company-prefix new-prefix)
 783                           (company-update-candidates c)
 784                           t))))
 785           (if (not (and (company-incremental-p company-prefix new-prefix)
 786                         (company-require-match-p)))
 787               (progn
 788                 (when (equal company-prefix (car company-candidates))
 789                   ;; cancel, but last input was actually success
 790                   (company-cancel company-prefix))
 791                 (setq company-candidates nil))
 792             (backward-delete-char (length new-prefix))
 793             (insert company-prefix)
 794             (ding)
 795             (message "Matching input is required")))
 796       (when (company-auto-complete-p company-point (point))
 797         (save-excursion
 798           (goto-char company-point)
 799           (company-complete-selection)))
 800       (setq company-candidates nil))
 801     company-candidates))
 802
 803 (defun company-begin ()
 804   (when (and (not (and company-candidates (company-continue)))
 805              (company--should-complete))
 806     (let (prefix)
 807       (dolist (backend (if company-backend
 808                            ;; prefer manual override
 809                            (list company-backend)
 810                          company-backends))
 811         (when (and (get backend 'company-init)
 812                    (functionp backend)
 813                    (setq prefix (funcall backend 'prefix)))
 814           (when (and (stringp prefix)
 815                      (>= (length prefix) company-minimum-prefix-length))
 816             (setq company-backend backend
 817                   company-prefix prefix)
 818             (let ((c (company-calculate-candidates prefix)))
 819               ;; t means complete/unique.  We don't start, so no hooks.
 820               (when (consp c)
 821                 (company-update-candidates c)
 822                 (run-hook-with-args 'company-completion-started-hook
 823                                     (company-explicit-action-p))
 824                 (company-call-frontends 'show))))
 825           (return prefix)))))
 826   (if company-candidates
 827       (progn
 828         (when (and company-end-of-buffer-workaround (eobp))
 829           (save-excursion (insert "\n"))
 830           (setq company-added-newline (buffer-chars-modified-tick)))
 831         (setq company-point (point))
 832         (company-enable-overriding-keymap company-active-map)
 833         (company-call-frontends 'update))
 834     (company-cancel)))
 835
 836 (defun company-cancel (&optional result)
 837   (and company-added-newline
 838        (> (point-max) (point-min))
 839        (let ((tick (buffer-chars-modified-tick)))
 840          (delete-region (1- (point-max)) (point-max))
 841          (equal tick company-added-newline))
 842        ;; Only set unmodified when tick remained the same since insert.
 843        (set-buffer-modified-p nil))
 844   (when company-prefix
 845     (if (stringp result)
 846         (run-hook-with-args 'company-completion-finished-hook result)
 847       (run-hook-with-args 'company-completion-cancelled-hook result)))
 848   (setq company-added-newline nil
 849         company-backend nil
 850         company-prefix nil
 851         company-candidates nil
 852         company-candidates-length nil
 853         company-candidates-cache nil
 854         company-candidates-predicate nil
 855         company-common nil
 856         company-selection 0
 857         company-selection-changed nil
 858         company--explicit-action nil
 859         company-point nil)
 860   (when company-timer
 861     (cancel-timer company-timer))
 862   (company-search-mode 0)
 863   (company-call-frontends 'hide)
 864   (company-enable-overriding-keymap nil))
 865
 866 (defun company-abort ()
 867   (interactive)
 868   (company-cancel t)
 869   ;; Don't start again, unless started manually.
 870   (setq company-point (point)))
 871
 872 (defun company-finish (result)
 873   (insert (company-strip-prefix result))
 874   (company-cancel result)
 875   ;; Don't start again, unless started manually.
 876   (setq company-point (point)))
 877
 878 (defsubst company-keep (command)
 879   (and (symbolp command) (get command 'company-keep)))
 880
 881 (defun company-pre-command ()
 882   (unless (company-keep this-command)
 883     (condition-case err
 884         (when company-candidates
 885           (company-call-frontends 'pre-command))
 886       (error (message "Company: An error occurred in pre-command")
 887              (message "%s" (error-message-string err))
 888              (company-cancel))))
 889   (when company-timer
 890     (cancel-timer company-timer))
 891   (company-uninstall-map))
 892
 893 (defun company-post-command ()
 894   (unless (company-keep this-command)
 895     (condition-case err
 896         (progn
 897           (setq company--this-command this-command)
 898           (unless (equal (point) company-point)
 899             (company-begin))
 900           (when company-candidates
 901             (company-call-frontends 'post-command))
 902           (when (numberp company-idle-delay)
 903             (setq company-timer
 904                   (run-with-timer company-idle-delay nil 'company-idle-begin
 905                                   (current-buffer) (selected-window)
 906                                   (buffer-chars-modified-tick) (point)))))
 907       (error (message "Company: An error occurred in post-command")
 908              (message "%s" (error-message-string err))
 909              (company-cancel))))
 910   (company-install-map))
 911
 912 ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 913
 914 (defvar company-search-string nil)
 915 (make-variable-buffer-local 'company-search-string)
 916
 917 (defvar company-search-lighter " Search: \"\"")
 918 (make-variable-buffer-local 'company-search-lighter)
 919
 920 (defvar company-search-old-map nil)
 921 (make-variable-buffer-local 'company-search-old-map)
 922
 923 (defvar company-search-old-selection 0)
 924 (make-variable-buffer-local 'company-search-old-selection)
 925
 926 (defun company-search (text lines)
 927   (let ((quoted (regexp-quote text))
 928         (i 0))
 929     (dolist (line lines)
 930       (when (string-match quoted line (length company-prefix))
 931         (return i))
 932       (incf i))))
 933
 934 (defun company-search-printing-char ()
 935   (interactive)
 936   (company-search-assert-enabled)
 937   (setq company-search-string
 938         (concat (or company-search-string "") (string last-command-event))
 939         company-search-lighter (concat " Search: \"" company-search-string
 940                                         "\""))
 941   (let ((pos (company-search company-search-string
 942                               (nthcdr company-selection company-candidates))))
 943     (if (null pos)
 944         (ding)
 945       (company-set-selection (+ company-selection pos) t))))
 946
 947 (defun company-search-repeat-forward ()
 948   "Repeat the incremental search in completion candidates forward."
 949   (interactive)
 950   (company-search-assert-enabled)
 951   (let ((pos (company-search company-search-string
 952                               (cdr (nthcdr company-selection
 953                                            company-candidates)))))
 954     (if (null pos)
 955         (ding)
 956       (company-set-selection (+ company-selection pos 1) t))))
 957
 958 (defun company-search-repeat-backward ()
 959   "Repeat the incremental search in completion candidates backwards."
 960   (interactive)
 961   (company-search-assert-enabled)
 962   (let ((pos (company-search company-search-string
 963                               (nthcdr (- company-candidates-length
 964                                          company-selection)
 965                                       (reverse company-candidates)))))
 966     (if (null pos)
 967         (ding)
 968       (company-set-selection (- company-selection pos 1) t))))
 969
 970 (defun company-create-match-predicate ()
 971   (setq company-candidates-predicate
 972         `(lambda (candidate)
 973            ,(if company-candidates-predicate
 974                 `(and (string-match ,company-search-string candidate)
 975                       (funcall ,company-candidates-predicate
 976                                candidate))
 977               `(string-match ,company-search-string candidate))))
 978   (company-update-candidates
 979    (company-apply-predicate company-candidates company-candidates-predicate))
 980   ;; Invalidate cache.
 981   (setq company-candidates-cache (cons company-prefix company-candidates)))
 982
 983 (defun company-filter-printing-char ()
 984   (interactive)
 985   (company-search-assert-enabled)
 986   (company-search-printing-char)
 987   (company-create-match-predicate)
 988   (company-call-frontends 'update))
 989
 990 (defun company-search-kill-others ()
 991   "Limit the completion candidates to the ones matching the search string."
 992   (interactive)
 993   (company-search-assert-enabled)
 994   (company-create-match-predicate)
 995   (company-search-mode 0)
 996   (company-call-frontends 'update))
 997
 998 (defun company-search-abort ()
 999   "Abort searching the completion candidates."
1000   (interactive)
1001   (company-search-assert-enabled)
1002   (company-set-selection company-search-old-selection t)
1003   (company-search-mode 0))
1004
1005 (defun company-search-other-char ()
1006   (interactive)
1007   (company-search-assert-enabled)
1008   (company-search-mode 0)
1009   (when last-input-event
1010     (clear-this-command-keys t)
1011     (setq unread-command-events (list last-input-event))))
1012
1013 (defvar company-search-map
1014   (let ((i 0)
1015         (keymap (make-keymap)))
1016     (if (fboundp 'max-char)
1017         (set-char-table-range (nth 1 keymap) (cons #x100 (max-char))
1018                               'company-search-printing-char)
1019       (with-no-warnings
1020         ;; obselete in Emacs 23
1021         (let ((l (generic-character-list))
1022               (table (nth 1 keymap)))
1023           (while l
1024             (set-char-table-default table (car l) 'company-search-printing-char)
1025             (setq l (cdr l))))))
1026     (define-key keymap [t] 'company-search-other-char)
1027     (while (< i ?\s)
1028       (define-key keymap (make-string 1 i) 'company-search-other-char)
1029       (incf i))
1030     (while (< i 256)
1031       (define-key keymap (vector i) 'company-search-printing-char)
1032       (incf i))
1033     (let ((meta-map (make-sparse-keymap)))
1034       (define-key keymap (char-to-string meta-prefix-char) meta-map)
1035       (define-key keymap [escape] meta-map))
1036     (define-key keymap (vector meta-prefix-char t) 'company-search-other-char)
1037     (define-key keymap "\e\e\e" 'company-search-other-char)
1038     (define-key keymap  [escape escape escape] 'company-search-other-char)
1039
1040     (define-key keymap "\C-g" 'company-search-abort)
1041     (define-key keymap "\C-s" 'company-search-repeat-forward)
1042     (define-key keymap "\C-r" 'company-search-repeat-backward)
1043     (define-key keymap "\C-o" 'company-search-kill-others)
1044     keymap)
1045   "Keymap used for incrementally searching the completion candidates.")
1046
1047 (define-minor-mode company-search-mode
1048   "Search mode for completion candidates.
1049 Don't start this directly, use `company-search-candidates' or
1050 `company-filter-candidates'."
1051   nil company-search-lighter nil
1052   (if company-search-mode
1053       (if (company-manual-begin)
1054           (progn
1055             (setq company-search-old-selection company-selection)
1056             (company-call-frontends 'update))
1057         (setq company-search-mode nil))
1058     (kill-local-variable 'company-search-string)
1059     (kill-local-variable 'company-search-lighter)
1060     (kill-local-variable 'company-search-old-selection)
1061     (company-enable-overriding-keymap company-active-map)))
1062
1063 (defsubst company-search-assert-enabled ()
1064   (company-assert-enabled)
1065   (unless company-search-mode
1066     (company-uninstall-map)
1067     (error "Company not in search mode")))
1068
1069 (defun company-search-candidates ()
1070   "Start searching the completion candidates incrementally.
1071
1072 \\<company-search-map>Search can be controlled with the commands:
1073 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
1074 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
1075 - `company-search-abort' (\\[company-search-abort])
1076
1077 Regular characters are appended to the search string.
1078
1079 The command `company-search-kill-others' (\\[company-search-kill-others]) uses
1080  the search string to limit the completion candidates."
1081   (interactive)
1082   (company-search-mode 1)
1083   (company-enable-overriding-keymap company-search-map))
1084
1085 (defvar company-filter-map
1086   (let ((keymap (make-keymap)))
1087     (define-key keymap [remap company-search-printing-char]
1088       'company-filter-printing-char)
1089     (set-keymap-parent keymap company-search-map)
1090     keymap)
1091   "Keymap used for incrementally searching the completion candidates.")
1092
1093 (defun company-filter-candidates ()
1094   "Start filtering the completion candidates incrementally.
1095 This works the same way as `company-search-candidates' immediately
1096 followed by `company-search-kill-others' after each input."
1097   (interactive)
1098   (company-search-mode 1)
1099   (company-enable-overriding-keymap company-filter-map))
1100
1101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1102
1103 (defun company-select-next ()
1104   "Select the next candidate in the list."
1105   (interactive)
1106   (when (company-manual-begin)
1107     (company-set-selection (1+ company-selection))))
1108
1109 (defun company-select-previous ()
1110   "Select the previous candidate in the list."
1111   (interactive)
1112   (when (company-manual-begin)
1113     (company-set-selection (1- company-selection))))
1114
1115 (defun company-select-mouse (event)
1116   "Select the candidate picked by the mouse."
1117   (interactive "e")
1118   (when (nth 4 (event-start event))
1119     (company-set-selection (- (cdr (posn-actual-col-row (event-start event)))
1120                               (cdr (posn-actual-col-row (posn-at-point)))
1121                               1))
1122     t))
1123
1124 (defun company-complete-mouse (event)
1125   "Complete the candidate picked by the mouse."
1126   (interactive "e")
1127   (when (company-select-mouse event)
1128     (company-complete-selection)))
1129
1130 (defun company-complete-selection ()
1131   "Complete the selected candidate."
1132   (interactive)
1133   (when (company-manual-begin)
1134     (company-finish (nth company-selection company-candidates))))
1135
1136 (defun company-complete-common ()
1137   "Complete the common part of all candidates."
1138   (interactive)
1139   (when (company-manual-begin)
1140     (if (and (not (cdr company-candidates))
1141              (equal company-common (car company-candidates)))
1142         (company-complete-selection)
1143       (insert (company-strip-prefix company-common)))))
1144
1145 (defun company-complete ()
1146   "Complete the common part of all candidates or the current selection.
1147 The first time this is called, the common part is completed, the second time, or
1148 when the selection has been changed, the selected candidate is completed."
1149   (interactive)
1150   (when (company-manual-begin)
1151     (if (or company-selection-changed
1152             (eq last-command 'company-complete-common))
1153         (call-interactively 'company-complete-selection)
1154       (call-interactively 'company-complete-common)
1155       (setq this-command 'company-complete-common))))
1156
1157 (defun company-complete-number (n)
1158   "Complete the Nth candidate.
1159 To show the number next to the candidates in some back-ends, enable
1160 `company-show-numbers'."
1161   (when (company-manual-begin)
1162     (and (< n 1) (> n company-candidates-length)
1163          (error "No candidate number %d" n))
1164     (decf n)
1165     (company-finish (nth n company-candidates))))
1166
1167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1168
1169 (defconst company-space-strings-limit 100)
1170
1171 (defconst company-space-strings
1172   (let (lst)
1173     (dotimes (i company-space-strings-limit)
1174       (push (make-string (- company-space-strings-limit 1 i) ?\  ) lst))
1175     (apply 'vector lst)))
1176
1177 (defsubst company-space-string (len)
1178   (if (< len company-space-strings-limit)
1179       (aref company-space-strings len)
1180     (make-string len ?\ )))
1181
1182 (defsubst company-safe-substring (str from &optional to)
1183   (let ((len (length str)))
1184     (if (> from len)
1185         ""
1186       (if (and to (> to len))
1187           (concat (substring str from)
1188                   (company-space-string (- to len)))
1189         (substring str from to)))))
1190
1191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1192
1193 (defvar company-last-metadata nil)
1194 (make-variable-buffer-local 'company-last-metadata)
1195
1196 (defun company-fetch-metadata ()
1197   (let ((selected (nth company-selection company-candidates)))
1198     (unless (equal selected (car company-last-metadata))
1199       (setq company-last-metadata
1200             (cons selected (company-call-backend 'meta selected))))
1201     (cdr company-last-metadata)))
1202
1203 (defun company-doc-buffer (&optional string)
1204   (with-current-buffer (get-buffer-create "*Company meta-data*")
1205     (erase-buffer)
1206     (current-buffer)))
1207
1208 (defmacro company-electric (&rest body)
1209   (declare (indent 0) (debug t))
1210   `(when (company-manual-begin)
1211      (save-window-excursion
1212        (let ((height (window-height))
1213              (row (cdr (posn-actual-col-row (posn-at-point)))))
1214          ,@body
1215          (and (< (window-height) height)
1216               (< (- (window-height) row 2) company-tooltip-limit)
1217               (recenter (- (window-height) row 2)))
1218          (while (eq 'scroll-other-window
1219                     (key-binding (vector (list (read-event)))))
1220            (call-interactively 'scroll-other-window))
1221          (when last-input-event
1222            (clear-this-command-keys t)
1223            (setq unread-command-events (list last-input-event)))))))
1224
1225 (defun company-show-doc-buffer ()
1226   "Temporarily show a buffer with the complete documentation for the selection."
1227   (interactive)
1228   (company-electric
1229     (let ((selected (nth company-selection company-candidates)))
1230       (display-buffer (or (company-call-backend 'doc-buffer selected)
1231                           (error "No documentation available")) t))))
1232 (put 'company-show-doc-buffer 'company-keep t)
1233
1234 (defun company-show-location ()
1235   "Temporarily display a buffer showing the selected candidate in context."
1236   (interactive)
1237   (company-electric
1238     (let* ((selected (nth company-selection company-candidates))
1239            (location (company-call-backend 'location selected))
1240            (pos (or (cdr location) (error "No location available")))
1241            (buffer (or (and (bufferp (car location)) (car location))
1242                        (find-file-noselect (car location) t))))
1243       (with-selected-window (display-buffer buffer t)
1244         (if (bufferp (car location))
1245             (goto-char pos)
1246           (goto-line pos))
1247         (set-window-start nil (point))))))
1248 (put 'company-show-location 'company-keep t)
1249
1250 ;;; package functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1251
1252 (defvar company-callback nil)
1253 (make-variable-buffer-local 'company-callback)
1254
1255 (defvar company-begin-with-marker nil)
1256 (make-variable-buffer-local 'company-begin-with-marker)
1257
1258 (defun company-remove-callback (&optional ignored)
1259   (remove-hook 'company-completion-finished-hook company-callback t)
1260   (remove-hook 'company-completion-cancelled-hook 'company-remove-callback t)
1261   (remove-hook 'company-completion-finished-hook 'company-remove-callback t)
1262   (set-marker company-begin-with-marker nil))
1263
1264 (defun company-begin-backend (backend &optional callback)
1265   "Start a completion at point using BACKEND."
1266   (interactive (let ((val (completing-read "Company back-end: "
1267                                            obarray
1268                                            'functionp nil "company-")))
1269                  (when val
1270                    (list (intern val)))))
1271   (when (setq company-callback callback)
1272     (add-hook 'company-completion-finished-hook company-callback nil t))
1273   (add-hook 'company-completion-cancelled-hook 'company-remove-callback nil t)
1274   (add-hook 'company-completion-finished-hook 'company-remove-callback nil t)
1275   (setq company-backend backend)
1276   ;; Return non-nil if active.
1277   (or (company-manual-begin)
1278       (error "Cannot complete at point")))
1279
1280 (defun company-begin-with (candidates
1281                            &optional prefix-length require-match callback)
1282   "Start a completion at point.
1283 CANDIDATES is the list of candidates to use and PREFIX-LENGTH is the length of
1284 the prefix that already is in the buffer before point.  It defaults to 0.
1285
1286 CALLBACK is a function called with the selected result if the user successfully
1287 completes the input.
1288
1289 Example:
1290 \(company-begin-with '\(\"foo\" \"foobar\" \"foobarbaz\"\)\)"
1291   (company-begin-backend
1292    (let ((start (- (point) (or prefix-length 0))))
1293      (setq company-begin-with-marker (copy-marker (point) t))
1294      `(lambda (command &optional arg &rest ignored)
1295         (case command
1296           ('prefix (when (equal (point)
1297                                 (marker-position company-begin-with-marker))
1298                      (buffer-substring ,start (point))))
1299           ('candidates (all-completions arg ',candidates))
1300           ('require-match ,require-match))))
1301    callback))
1302
1303 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1304
1305 (defvar company-pseudo-tooltip-overlay nil)
1306 (make-variable-buffer-local 'company-pseudo-tooltip-overlay)
1307
1308 (defvar company-tooltip-offset 0)
1309 (make-variable-buffer-local 'company-tooltip-offset)
1310
1311 (defun company-pseudo-tooltip-update-offset (selection num-lines limit)
1312
1313   (decf limit 2)
1314   (setq company-tooltip-offset
1315         (max (min selection company-tooltip-offset)
1316              (- selection -1 limit)))
1317
1318   (when (<= company-tooltip-offset 1)
1319     (incf limit)
1320     (setq company-tooltip-offset 0))
1321
1322   (when (>= company-tooltip-offset (- num-lines limit 1))
1323     (incf limit)
1324     (when (= selection (1- num-lines))
1325       (decf company-tooltip-offset)
1326       (when (<= company-tooltip-offset 1)
1327         (setq company-tooltip-offset 0)
1328         (incf limit))))
1329
1330   limit)
1331
1332 ;;; propertize
1333
1334 (defsubst company-round-tab (arg)
1335   (* (/ (+ arg tab-width) tab-width) tab-width))
1336
1337 (defun company-untabify (str)
1338   (let* ((pieces (split-string str "\t"))
1339          (copy pieces))
1340     (while (cdr copy)
1341       (setcar copy (company-safe-substring
1342                     (car copy) 0 (company-round-tab (string-width (car copy)))))
1343       (pop copy))
1344     (apply 'concat pieces)))
1345
1346 (defun company-fill-propertize (line width selected)
1347   (setq line (company-safe-substring line 0 width))
1348   (add-text-properties 0 width '(face company-tooltip
1349                                  mouse-face company-tooltip-mouse)
1350                        line)
1351   (add-text-properties 0 (length company-common)
1352                        '(face company-tooltip-common
1353                          mouse-face company-tooltip-mouse)
1354                        line)
1355   (when selected
1356     (if (and company-search-string
1357              (string-match (regexp-quote company-search-string) line
1358                            (length company-prefix)))
1359         (progn
1360           (add-text-properties (match-beginning 0) (match-end 0)
1361                                '(face company-tooltip-selection)
1362                                line)
1363           (when (< (match-beginning 0) (length company-common))
1364             (add-text-properties (match-beginning 0) (length company-common)
1365                                  '(face company-tooltip-common-selection)
1366                                  line)))
1367       (add-text-properties 0 width '(face company-tooltip-selection
1368                                           mouse-face company-tooltip-selection)
1369                            line)
1370       (add-text-properties 0 (length company-common)
1371                            '(face company-tooltip-common-selection
1372                              mouse-face company-tooltip-selection)
1373                            line)))
1374   line)
1375
1376 ;;; replace
1377
1378 (defun company-buffer-lines (beg end)
1379   (goto-char beg)
1380   (let ((row (cdr (posn-actual-col-row (posn-at-point))))
1381         lines)
1382     (while (and (equal (move-to-window-line (incf row)) row)
1383                 (<= (point) end))
1384       (push (buffer-substring beg (min end (1- (point)))) lines)
1385       (setq beg (point)))
1386     (unless (eq beg end)
1387       (push (buffer-substring beg end) lines))
1388     (nreverse lines)))
1389
1390 (defsubst company-modify-line (old new offset)
1391   (concat (company-safe-substring old 0 offset)
1392           new
1393           (company-safe-substring old (+ offset (length new)))))
1394
1395 (defun company-replacement-string (old lines column nl)
1396   (let (new)
1397     ;; Inject into old lines.
1398     (while old
1399       (push (company-modify-line (pop old) (pop lines) column) new))
1400     ;; Append whole new lines.
1401     (while lines
1402       (push (concat (company-space-string column) (pop lines)) new))
1403     (concat (when nl "\n")
1404             (mapconcat 'identity (nreverse new) "\n")
1405             "\n")))
1406
1407 (defun company-create-lines (column selection limit)
1408
1409   (let ((len company-candidates-length)
1410         (numbered 99999)
1411         lines
1412         width
1413         lines-copy
1414         previous
1415         remainder
1416         new)
1417
1418     ;; Scroll to offset.
1419     (setq limit (company-pseudo-tooltip-update-offset selection len limit))
1420
1421     (when (> company-tooltip-offset 0)
1422       (setq previous (format "...(%d)" company-tooltip-offset)))
1423
1424     (setq remainder (- len limit company-tooltip-offset)
1425           remainder (when (> remainder 0)
1426                       (setq remainder (format "...(%d)" remainder))))
1427
1428     (decf selection company-tooltip-offset)
1429     (setq width (min (length previous) (length remainder))
1430           lines (nthcdr company-tooltip-offset company-candidates)
1431           len (min limit len)
1432           lines-copy lines)
1433
1434     (dotimes (i len)
1435       (setq width (max (length (pop lines-copy)) width)))
1436     (setq width (min width (- (window-width) column)))
1437
1438     (setq lines-copy lines)
1439
1440     ;; number can make tooltip too long
1441     (when company-show-numbers
1442       (setq numbered company-tooltip-offset))
1443
1444     (when previous
1445       (push (propertize (company-safe-substring previous 0 width)
1446                         'face 'company-tooltip)
1447             new))
1448
1449     (dotimes (i len)
1450       (push (company-fill-propertize
1451              (if (>= numbered 10)
1452                  (company-reformat (pop lines))
1453                (incf numbered)
1454                (format "%s %d"
1455                        (company-safe-substring (company-reformat (pop lines))
1456                                                0 (- width 2))
1457                        (mod numbered 10)))
1458              width (equal i selection))
1459             new))
1460
1461     (when remainder
1462       (push (propertize (company-safe-substring remainder 0 width)
1463                         'face 'company-tooltip)
1464             new))
1465
1466     (setq lines (nreverse new))))
1467
1468 ;; show
1469
1470 (defsubst company-pseudo-tooltip-height ()
1471   "Calculate the appropriate tooltip height."
1472   (max 3 (min company-tooltip-limit
1473               (- (window-height) 2
1474                  (count-lines (window-start) (point-at-bol))))))
1475
1476 (defun company-pseudo-tooltip-show (row column selection)
1477   (company-pseudo-tooltip-hide)
1478   (save-excursion
1479
1480     (move-to-column 0)
1481
1482     (let* ((height (company-pseudo-tooltip-height))
1483            (lines (company-create-lines column selection height))
1484            (nl (< (move-to-window-line row) row))
1485            (beg (point))
1486            (end (save-excursion
1487                   (move-to-window-line (+ row height))
1488                   (point)))
1489            (old-string
1490             (mapcar 'company-untabify (company-buffer-lines beg end)))
1491            str)
1492
1493       (setq company-pseudo-tooltip-overlay (make-overlay beg end))
1494
1495       (overlay-put company-pseudo-tooltip-overlay 'company-old old-string)
1496       (overlay-put company-pseudo-tooltip-overlay 'company-column column)
1497       (overlay-put company-pseudo-tooltip-overlay 'company-nl nl)
1498       (overlay-put company-pseudo-tooltip-overlay 'company-before
1499                    (company-replacement-string old-string lines column nl))
1500       (overlay-put company-pseudo-tooltip-overlay 'company-height height)
1501
1502       (overlay-put company-pseudo-tooltip-overlay 'window (selected-window)))))
1503
1504 (defun company-pseudo-tooltip-show-at-point (pos)
1505   (let ((col-row (posn-actual-col-row (posn-at-point pos))))
1506     (when col-row
1507       (company-pseudo-tooltip-show (1+ (cdr col-row)) (car col-row)
1508                                    company-selection))))
1509
1510 (defun company-pseudo-tooltip-edit (lines selection)
1511   (let* ((old-string (overlay-get company-pseudo-tooltip-overlay 'company-old))
1512          (column (overlay-get company-pseudo-tooltip-overlay 'company-column))
1513          (nl (overlay-get company-pseudo-tooltip-overlay 'company-nl))
1514          (height (overlay-get company-pseudo-tooltip-overlay 'company-height))
1515          (lines (company-create-lines column selection height)))
1516     (overlay-put company-pseudo-tooltip-overlay 'company-before
1517                  (company-replacement-string old-string lines column nl))))
1518
1519 (defun company-pseudo-tooltip-hide ()
1520   (when company-pseudo-tooltip-overlay
1521     (delete-overlay company-pseudo-tooltip-overlay)
1522     (setq company-pseudo-tooltip-overlay nil)))
1523
1524 (defun company-pseudo-tooltip-hide-temporarily ()
1525   (when (overlayp company-pseudo-tooltip-overlay)
1526     (overlay-put company-pseudo-tooltip-overlay 'invisible nil)
1527     (overlay-put company-pseudo-tooltip-overlay 'before-string nil)))
1528
1529 (defun company-pseudo-tooltip-unhide ()
1530   (when company-pseudo-tooltip-overlay
1531     (overlay-put company-pseudo-tooltip-overlay 'invisible t)
1532     (overlay-put company-pseudo-tooltip-overlay 'before-string
1533                  (overlay-get company-pseudo-tooltip-overlay 'company-before))
1534     (overlay-put company-pseudo-tooltip-overlay 'window (selected-window))))
1535
1536 (defun company-pseudo-tooltip-frontend (command)
1537   "A `company-mode' front-end similar to a tool-tip but based on overlays."
1538   (case command
1539     ('pre-command (company-pseudo-tooltip-hide-temporarily))
1540     ('post-command
1541      (unless (and (overlayp company-pseudo-tooltip-overlay)
1542                   (equal (overlay-get company-pseudo-tooltip-overlay
1543                                       'company-height)
1544                          (company-pseudo-tooltip-height)))
1545        ;; Redraw needed.
1546        (company-pseudo-tooltip-show-at-point (- (point)
1547                                                 (length company-prefix))))
1548      (company-pseudo-tooltip-unhide))
1549     ('hide (company-pseudo-tooltip-hide)
1550            (setq company-tooltip-offset 0))
1551     ('update (when (overlayp company-pseudo-tooltip-overlay)
1552                (company-pseudo-tooltip-edit company-candidates
1553                                             company-selection)))))
1554
1555 (defun company-pseudo-tooltip-unless-just-one-frontend (command)
1556   "`company-pseudo-tooltip-frontend', but not shown for single candidates."
1557   (unless (and (eq command 'post-command)
1558                (not (cdr company-candidates)))
1559     (company-pseudo-tooltip-frontend command)))
1560
1561 ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1562
1563 (defvar company-preview-overlay nil)
1564 (make-variable-buffer-local 'company-preview-overlay)
1565
1566 (defun company-preview-show-at-point (pos)
1567   (company-preview-hide)
1568
1569   (setq company-preview-overlay (make-overlay pos pos))
1570
1571   (let ((completion(nth company-selection company-candidates)))
1572     (setq completion (propertize completion 'face 'company-preview))
1573     (add-text-properties 0 (length company-common)
1574                          '(face company-preview-common) completion)
1575
1576     ;; Add search string
1577     (and company-search-string
1578          (string-match (regexp-quote company-search-string) completion)
1579          (add-text-properties (match-beginning 0)
1580                               (match-end 0)
1581                               '(face company-preview-search)
1582                               completion))
1583
1584     (setq completion (company-strip-prefix completion))
1585
1586     (and (equal pos (point))
1587          (not (equal completion ""))
1588          (add-text-properties 0 1 '(cursor t) completion))
1589
1590     (overlay-put company-preview-overlay 'after-string completion)
1591     (overlay-put company-preview-overlay 'window (selected-window))))
1592
1593 (defun company-preview-hide ()
1594   (when company-preview-overlay
1595     (delete-overlay company-preview-overlay)
1596     (setq company-preview-overlay nil)))
1597
1598 (defun company-preview-frontend (command)
1599   "A `company-mode' front-end showing the selection as if it had been inserted."
1600   (case command
1601     ('pre-command (company-preview-hide))
1602     ('post-command (company-preview-show-at-point (point)))
1603     ('hide (company-preview-hide))))
1604
1605 (defun company-preview-if-just-one-frontend (command)
1606   "`company-preview-frontend', but only shown for single candidates."
1607   (unless (and (eq command 'post-command)
1608                (cdr company-candidates))
1609     (company-preview-frontend command)))
1610
1611 ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1612
1613 (defvar company-echo-last-msg nil)
1614 (make-variable-buffer-local 'company-echo-last-msg)
1615
1616 (defvar company-echo-timer nil)
1617
1618 (defvar company-echo-delay .1)
1619
1620 (defun company-echo-show (&optional getter)
1621   (when getter
1622     (setq company-echo-last-msg (funcall getter)))
1623   (let ((message-log-max nil))
1624     (if company-echo-last-msg
1625         (message "%s" company-echo-last-msg)
1626       (message ""))))
1627
1628 (defsubst company-echo-show-soon (&optional getter)
1629   (when company-echo-timer
1630     (cancel-timer company-echo-timer))
1631   (setq company-echo-timer (run-with-timer company-echo-delay nil
1632                                            'company-echo-show getter)))
1633
1634 (defun company-echo-format ()
1635
1636   (let ((limit (window-width (minibuffer-window)))
1637         (len -1)
1638         ;; Roll to selection.
1639         (candidates (nthcdr company-selection company-candidates))
1640         (i (if company-show-numbers company-selection 99999))
1641         comp msg)
1642
1643     (while candidates
1644       (setq comp (company-reformat (pop candidates))
1645             len (+ len 1 (length comp)))
1646       (if (< i 10)
1647           ;; Add number.
1648           (progn
1649             (setq comp (propertize (format "%d: %s" i comp)
1650                                    'face 'company-echo))
1651             (incf len 3)
1652             (incf i)
1653             (add-text-properties 3 (+ 3 (length company-common))
1654                                  '(face company-echo-common) comp))
1655         (setq comp (propertize comp 'face 'company-echo))
1656         (add-text-properties 0 (length company-common)
1657                              '(face company-echo-common) comp))
1658       (if (>= len limit)
1659           (setq candidates nil)
1660         (push comp msg)))
1661
1662     (mapconcat 'identity (nreverse msg) " ")))
1663
1664 (defun company-echo-strip-common-format ()
1665
1666   (let ((limit (window-width (minibuffer-window)))
1667         (len (+ (length company-prefix) 2))
1668         ;; Roll to selection.
1669         (candidates (nthcdr company-selection company-candidates))
1670         (i (if company-show-numbers company-selection 99999))
1671         msg comp)
1672
1673     (while candidates
1674       (setq comp (company-strip-prefix (pop candidates))
1675             len (+ len 2 (length comp)))
1676       (when (< i 10)
1677         ;; Add number.
1678         (setq comp (format "%s (%d)" comp i))
1679         (incf len 4)
1680         (incf i))
1681       (if (>= len limit)
1682           (setq candidates nil)
1683         (push (propertize comp 'face 'company-echo) msg)))
1684
1685     (concat (propertize company-prefix 'face 'company-echo-common) "{"
1686             (mapconcat 'identity (nreverse msg) ", ")
1687             "}")))
1688
1689 (defun company-echo-hide ()
1690   (when company-echo-timer
1691     (cancel-timer company-echo-timer))
1692   (unless (equal company-echo-last-msg "")
1693     (setq company-echo-last-msg "")
1694     (company-echo-show)))
1695
1696 (defun company-echo-frontend (command)
1697   "A `company-mode' front-end showing the candidates in the echo area."
1698   (case command
1699     ('pre-command (company-echo-show-soon))
1700     ('post-command (company-echo-show-soon 'company-echo-format))
1701     ('hide (company-echo-hide))))
1702
1703 (defun company-echo-strip-common-frontend (command)
1704   "A `company-mode' front-end showing the candidates in the echo area."
1705   (case command
1706     ('pre-command (company-echo-show-soon))
1707     ('post-command (company-echo-show-soon 'company-echo-strip-common-format))
1708     ('hide (company-echo-hide))))
1709
1710 (defun company-echo-metadata-frontend (command)
1711   "A `company-mode' front-end showing the documentation in the echo area."
1712   (case command
1713     ('pre-command (company-echo-show-soon))
1714     ('post-command (company-echo-show-soon 'company-fetch-metadata))
1715     ('hide (company-echo-hide))))
1716
1717 (provide 'company)
1718 ;;; company.el ends here