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