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