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