code.delx.au - gnu-emacs-elpa/blob - company.el

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