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.1.5
   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 ;; Known Issues:
  53 ;; When point is at the very end of the buffer, the pseudo-tooltip appears very
  54 ;; wrong.
  55 ;;
  56 ;;; Change Log:
  57 ;;
  58 ;;    Added `company-filter-candidates'.
  59 ;;    More local Lisp variables are now included in the candidates.
  60 ;;
  61 ;; 2009-03-21 (0.1.5)
  62 ;;    Fixed elisp documentation buffer always showing the same doc.
  63 ;;    Added `company-echo-strip-common-frontend'.
  64 ;;    Added `company-show-numbers' option and M-0 ... M-9 default bindings.
  65 ;;    Don't hide the echo message if it isn't shown.
  66 ;;
  67 ;; 2009-03-20 (0.1)
  68 ;;    Initial release.
  69 ;;
  70 ;;; Code:
  71
  72 (eval-when-compile (require 'cl))
  73
  74 (add-to-list 'debug-ignored-errors
  75              "^Pseudo tooltip frontend cannot be used twice$")
  76 (add-to-list 'debug-ignored-errors "^Preview frontend cannot be used twice$")
  77 (add-to-list 'debug-ignored-errors "^Echo area cannot be used twice$")
  78 (add-to-list 'debug-ignored-errors "^No documentation available$")
  79 (add-to-list 'debug-ignored-errors "^Company not enabled$")
  80 (add-to-list 'debug-ignored-errors "^Company not in search mode$")
  81 (add-to-list 'debug-ignored-errors "^No candidate number ")
  82
  83 (defgroup company nil
  84   "Extensible inline text completion mechanism"
  85   :group 'abbrev
  86   :group 'convenience
  87   :group 'maching)
  88
  89 (defface company-tooltip
  90   '((t :background "yellow"
  91        :foreground "black"))
  92   "*Face used for the tool tip."
  93   :group 'company)
  94
  95 (defface company-tooltip-selection
  96   '((default :inherit company-tooltip)
  97     (((class color) (min-colors 88)) (:background "orange1"))
  98     (t (:background "green")))
  99   "*Face used for the selection in the tool tip."
 100   :group 'company)
 101
 102 (defface company-tooltip-common
 103   '((t :inherit company-tooltip
 104        :foreground "red"))
 105   "*Face used for the common completion in the tool tip."
 106   :group 'company)
 107
 108 (defface company-tooltip-common-selection
 109   '((t :inherit company-tooltip-selection
 110        :foreground "red"))
 111   "*Face used for the selected common completion in the tool tip."
 112   :group 'company)
 113
 114 (defcustom company-tooltip-limit 10
 115   "*The maximum number of candidates in the tool tip"
 116   :group 'company
 117   :type 'integer)
 118
 119 (defface company-preview
 120   '((t :background "blue4"
 121        :foreground "wheat"))
 122   "*Face used for the completion preview."
 123   :group 'company)
 124
 125 (defface company-preview-common
 126   '((t :inherit company-preview
 127        :foreground "red"))
 128   "*Face used for the common part of the completion preview."
 129   :group 'company)
 130
 131 (defface company-echo nil
 132   "*Face used for completions in the echo area."
 133   :group 'company)
 134
 135 (defface company-echo-common
 136   '((((background dark)) (:foreground "firebrick1"))
 137     (((background light)) (:background "firebrick4")))
 138   "*Face used for the common part of completions in the echo area."
 139   :group 'company)
 140
 141 (defun company-frontends-set (variable value)
 142   ;; uniquify
 143   (let ((remainder value))
 144     (setcdr remainder (delq (car remainder) (cdr remainder))))
 145   (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
 146        (memq 'company-pseudo-tooltip-frontend value)
 147        (error "Pseudo tooltip frontend cannot be used twice"))
 148   (and (memq 'company-preview-if-just-one-frontend value)
 149        (memq 'company-preview-frontend value)
 150        (error "Preview frontend cannot be used twice"))
 151   (and (memq 'company-echo value)
 152        (memq 'company-echo-metadata-frontend value)
 153        (error "Echo area cannot be used twice"))
 154   ;; preview must come last
 155   (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend))
 156     (when (memq f value)
 157       (setq value (append (delq f value) (list f)))))
 158   (set variable value))
 159
 160 (defcustom company-frontends '(company-pseudo-tooltip-unless-just-one-frontend
 161                                company-preview-if-just-one-frontend
 162                                company-echo-metadata-frontend)
 163   "*The list of active front-ends (visualizations).
 164 Each front-end is a function that takes one argument.  It is called with
 165 one of the following arguments:
 166
 167 'show: When the visualization should start.
 168
 169 'hide: When the visualization should end.
 170
 171 'update: When the data has been updated.
 172
 173 'pre-command: Before every command that is executed while the
 174 visualization is active.
 175
 176 'post-command: After every command that is executed while the
 177 visualization is active.
 178
 179 The visualized data is stored in `company-prefix', `company-candidates',
 180 `company-common', `company-selection', `company-point' and
 181 `company-search-string'."
 182   :set 'company-frontends-set
 183   :group 'company
 184   :type '(repeat (choice (const :tag "echo" company-echo-frontend)
 185                          (const :tag "echo, strip common"
 186                                 company-echo-strip-common-frontend)
 187                          (const :tag "show echo meta-data in echo"
 188                                 company-echo-metadata-frontend)
 189                          (const :tag "pseudo tooltip"
 190                                 company-pseudo-tooltip-frontend)
 191                          (const :tag "pseudo tooltip, multiple only"
 192                                 company-pseudo-tooltip-unless-just-one-frontend)
 193                          (const :tag "preview" company-preview-frontend)
 194                          (const :tag "preview, unique only"
 195                                 company-preview-if-just-one-frontend)
 196                          (function :tag "custom function" nil))))
 197
 198 (defcustom company-backends '(company-elisp company-nxml company-css
 199                               company-semantic company-gtags company-oddmuse
 200                               company-files company-dabbrev)
 201   "*The list of active back-ends (completion engines).
 202 Each back-end is a function that takes a variable number of arguments.
 203 The first argument is the command requested from the back-end.  It is one
 204 of the following:
 205
 206 'prefix: The back-end should return the text to be completed.  It must be
 207 text immediately before `point'.  Returning nil passes control to the next
 208 back-end.
 209
 210 'candidates: The second argument is the prefix to be completed.  The
 211 return value should be a list of candidates that start with the prefix.
 212
 213 Optional commands:
 214
 215 'sorted: The back-end may return t here to indicate that the candidates
 216 are sorted and will not need to be sorted again.
 217
 218 'no-cache: Usually company doesn't ask for candidates again as completion
 219 progresses, unless the back-end returns t for this command.  The second
 220 argument is the latest prefix.
 221
 222 'meta: The second argument is a completion candidate.  The back-end should
 223 return a (short) documentation string for it.
 224
 225 'doc-buffer: The second argument is a completion candidate.  The back-end should
 226 create a buffer (preferably with `company-doc-buffer'), fill it with
 227 documentation and return it.
 228
 229 The back-end should return nil for all commands it does not support or
 230 does not know about."
 231   :group 'company
 232   :type '(repeat (function :tag "function" nil)))
 233
 234 (defcustom company-minimum-prefix-length 3
 235   "*The minimum prefix length for automatic completion."
 236   :group 'company
 237   :type '(integer :tag "prefix length"))
 238
 239 (defcustom company-idle-delay .7
 240   "*The idle delay in seconds until automatic completions starts.
 241 A value of nil means never complete automatically, t means complete
 242 immediately when a prefix of `company-minimum-prefix-length' is reached."
 243   :group 'company
 244   :type '(choice (const :tag "never (nil)" nil)
 245                  (const :tag "immediate (t)" t)
 246                  (number :tag "seconds")))
 247
 248 (defcustom company-show-numbers nil
 249   "*If enabled, show quick-access numbers for the first ten candidates."
 250   :group 'company
 251   :type '(choice (const :tag "off" nil)
 252                  (const :tag "on" t)))
 253
 254 ;;; mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 255
 256 (defvar company-mode-map (make-sparse-keymap)
 257   "Keymap used by `company-mode'.")
 258
 259 (defvar company-active-map
 260   (let ((keymap (make-sparse-keymap)))
 261     (define-key keymap (kbd "M-n") 'company-select-next)
 262     (define-key keymap (kbd "M-p") 'company-select-previous)
 263     (define-key keymap (kbd "<down>") 'company-select-next)
 264     (define-key keymap (kbd "<up>") 'company-select-previous)
 265     (define-key keymap "\C-m" 'company-complete-selection)
 266     (define-key keymap "\t" 'company-complete-common)
 267     (define-key keymap (kbd "<f1>") 'company-show-doc-buffer)
 268     (define-key keymap "\C-s" 'company-search-candidates)
 269     (define-key keymap "\C-\M-s" 'company-filter-candidates)
 270     (dotimes (i 10)
 271       (define-key keymap (vector (+ (aref (kbd "M-0") 0) i))
 272         `(lambda () (interactive) (company-complete-number ,i))))
 273
 274     keymap)
 275   "Keymap that is enabled during an active completion.")
 276
 277 ;;;###autoload
 278 (define-minor-mode company-mode
 279   "\"complete anything\"; in in-buffer completion framework.
 280 Completion starts automatically, depending on the values
 281 `company-idle-delay' and `company-minimum-prefix-length'.
 282
 283 Completion can be controlled with the commands:
 284 `company-complete-common', `company-complete-selection', `company-complete',
 285 `company-select-next', `company-select-previous'.  If these commands are
 286 called before `company-idle-delay', completion will also start.
 287
 288 Completions can be searched with `company-search-candidates' or
 289 `company-filter-candidates'.
 290
 291 The completion data is retrieved using `company-backends' and displayed using
 292 `company-frontends'.
 293
 294 regular keymap:
 295
 296 \\{company-mode-map}
 297 keymap during active completions:
 298
 299 \\{company-active-map}"
 300   nil " comp" company-mode-map
 301   (if company-mode
 302       (progn
 303         (add-hook 'pre-command-hook 'company-pre-command nil t)
 304         (add-hook 'post-command-hook 'company-post-command nil t)
 305         (dolist (backend company-backends)
 306           (unless (fboundp backend)
 307             (ignore-errors (require backend nil t)))
 308           (unless (fboundp backend)
 309             (message "Company back-end '%s' could not be initialized"
 310                      backend))))
 311     (remove-hook 'pre-command-hook 'company-pre-command t)
 312     (remove-hook 'post-command-hook 'company-post-command t)
 313     (company-cancel)
 314     (kill-local-variable 'company-point)))
 315
 316 ;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 317
 318 (defvar company-overriding-keymap-bound nil)
 319 (make-variable-buffer-local 'company-overriding-keymap-bound)
 320
 321 (defvar company-old-keymap nil)
 322 (make-variable-buffer-local 'company-old-keymap)
 323
 324 (defvar company-my-keymap nil)
 325 (make-variable-buffer-local 'company-my-keymap)
 326
 327 (defsubst company-enable-overriding-keymap (keymap)
 328   (setq company-my-keymap keymap)
 329   (when company-overriding-keymap-bound
 330     (company-uninstall-map)))
 331
 332 (defun company-install-map ()
 333   (unless (or company-overriding-keymap-bound
 334               (null company-my-keymap))
 335     (setq company-old-keymap overriding-terminal-local-map
 336           overriding-terminal-local-map company-my-keymap
 337           company-overriding-keymap-bound t)))
 338
 339 (defun company-uninstall-map ()
 340   (when (and company-overriding-keymap-bound
 341              (eq overriding-terminal-local-map company-my-keymap))
 342     (setq overriding-terminal-local-map company-old-keymap
 343           company-overriding-keymap-bound nil)))
 344
 345 ;; Hack:
 346 ;; Emacs calculates the active keymaps before reading the event.  That means we
 347 ;; cannot change the keymap from a timer.  So we send a bogus command.
 348 (defun company-ignore ()
 349   (interactive))
 350
 351 (global-set-key '[31415926] 'company-ignore)
 352
 353 (defun company-input-noop ()
 354   (push 31415926 unread-command-events))
 355
 356 ;;; backends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 357
 358 (defun company-grab (regexp &optional expression)
 359   (when (looking-back regexp)
 360     (or (match-string-no-properties (or expression 0)) "")))
 361
 362 (defun company-in-string-or-comment (&optional point)
 363   (let ((pos (syntax-ppss)))
 364     (or (nth 3 pos) (nth 4 pos) (nth 7 pos))))
 365
 366 ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 367
 368 (defvar company-backend nil)
 369 (make-variable-buffer-local 'company-backend)
 370
 371 (defvar company-prefix nil)
 372 (make-variable-buffer-local 'company-prefix)
 373
 374 (defvar company-candidates nil)
 375 (make-variable-buffer-local 'company-candidates)
 376
 377 (defvar company-candidates-length nil)
 378 (make-variable-buffer-local 'company-candidates-length)
 379
 380 (defvar company-candidates-cache nil)
 381 (make-variable-buffer-local 'company-candidates-cache)
 382
 383 (defvar company-candidates-predicate nil)
 384 (make-variable-buffer-local 'company-candidates-predicate)
 385
 386 (defvar company-common nil)
 387 (make-variable-buffer-local 'company-common)
 388
 389 (defvar company-selection 0)
 390 (make-variable-buffer-local 'company-selection)
 391
 392 (defvar company-selection-changed nil)
 393 (make-variable-buffer-local 'company-selection-changed)
 394
 395 (defvar company-point nil)
 396 (make-variable-buffer-local 'company-point)
 397
 398 (defvar company-timer nil)
 399
 400 (defsubst company-strip-prefix (str)
 401   (substring str (length company-prefix)))
 402
 403 (defsubst company-reformat (candidate)
 404   ;; company-ispell needs this, because the results are always lower-case
 405   ;; It's mory efficient to fix it only when they are displayed.
 406   (concat company-prefix (substring candidate (length company-prefix))))
 407
 408 (defsubst company-should-complete (prefix)
 409   (and (eq company-idle-delay t)
 410        (>= (length prefix) company-minimum-prefix-length)))
 411
 412 (defsubst company-call-frontends (command)
 413   (dolist (frontend company-frontends)
 414     (condition-case err
 415         (funcall frontend command)
 416       (error (error "Company: Front-end %s error \"%s\" on command %s"
 417                     frontend (error-message-string err) command)))))
 418
 419 (defsubst company-set-selection (selection &optional force-update)
 420   (setq selection (max 0 (min (1- company-candidates-length) selection)))
 421   (when (or force-update (not (equal selection company-selection)))
 422     (setq company-selection selection
 423           company-selection-changed t)
 424     (company-call-frontends 'update)))
 425
 426 (defun company-apply-predicate (candidates predicate)
 427   (let (new)
 428     (dolist (c candidates)
 429       (when (funcall predicate c)
 430         (push c new)))
 431     (nreverse new)))
 432
 433 (defun company-update-candidates (candidates)
 434   (setq company-candidates-length (length candidates))
 435   (if (> company-selection 0)
 436       ;; Try to restore the selection
 437       (let ((selected (nth company-selection company-candidates)))
 438         (setq company-selection 0
 439               company-candidates candidates)
 440         (when selected
 441           (while (and candidates (string< (pop candidates) selected))
 442             (incf company-selection))
 443           (unless candidates
 444             ;; Make sure selection isn't out of bounds.
 445             (setq company-selection (min (1- company-candidates-length)
 446                                          company-selection)))))
 447     (setq company-selection 0
 448           company-candidates candidates))
 449   ;; Calculate common.
 450   (let ((completion-ignore-case (funcall company-backend 'ignore-case)))
 451     (setq company-common (try-completion company-prefix company-candidates)))
 452   (when (eq company-common t)
 453     (setq company-candidates nil)))
 454
 455 (defsubst company-calculate-candidates (prefix)
 456   (setq company-prefix prefix)
 457   (company-update-candidates
 458    (or (cdr (assoc prefix company-candidates-cache))
 459        (when company-candidates-cache
 460          (let ((len (length prefix))
 461                (completion-ignore-case (funcall company-backend 'ignore-case))
 462                prev)
 463            (dotimes (i len)
 464              (when (setq prev (cdr (assoc (substring prefix 0 (- len i))
 465                                           company-candidates-cache)))
 466                (return (all-completions prefix prev))))))
 467        (let ((candidates (funcall company-backend 'candidates prefix)))
 468          (when company-candidates-predicate
 469            (setq candidates
 470                  (company-apply-predicate candidates
 471                                           company-candidates-predicate)))
 472          (unless (funcall company-backend 'sorted)
 473            (setq candidates (sort candidates 'string<)))
 474          candidates)))
 475   (unless (assoc prefix company-candidates-cache)
 476     (push (cons prefix company-candidates) company-candidates-cache))
 477   company-candidates)
 478
 479 (defun company-idle-begin (buf win tick pos)
 480   (and company-mode
 481        (eq buf (current-buffer))
 482        (eq win (selected-window))
 483        (eq tick (buffer-chars-modified-tick))
 484        (eq pos (point))
 485        (not company-candidates)
 486        (not (equal (point) company-point))
 487        (let ((company-idle-delay t))
 488          (company-begin)
 489          (when company-candidates
 490            (company-input-noop)
 491            (company-post-command)))))
 492
 493 (defun company-manual-begin ()
 494   (interactive)
 495   (unless company-mode (error "Company not enabled"))
 496   (and company-mode
 497        (not company-candidates)
 498        (let ((company-idle-delay t)
 499              (company-minimum-prefix-length 0))
 500          (company-begin)))
 501   ;; Return non-nil if active.
 502   company-candidates)
 503
 504 (defun company-continue ()
 505   (when company-candidates
 506     (when (funcall company-backend 'no-cache company-prefix)
 507       ;; Don't complete existing candidates, fetch new ones.
 508       (setq company-candidates-cache nil))
 509     (let ((new-prefix (funcall company-backend 'prefix)))
 510       (unless (and (= (- (point) (length new-prefix))
 511                       (- company-point (length company-prefix)))
 512                    (or (equal company-prefix new-prefix)
 513                        (company-calculate-candidates new-prefix)))
 514         (setq company-candidates nil)))))
 515
 516 (defun company-begin ()
 517   (if (or buffer-read-only overriding-terminal-local-map overriding-local-map)
 518       ;; Don't complete in these cases.
 519       (setq company-candidates nil)
 520     (company-continue)
 521     (unless company-candidates
 522       (let (prefix)
 523         (dolist (backend company-backends)
 524           (and (fboundp backend)
 525                (setq prefix (funcall backend 'prefix))
 526                (company-should-complete prefix)
 527                (setq company-backend backend)
 528                (company-calculate-candidates prefix))
 529           (return prefix)))))
 530   (if company-candidates
 531       (progn
 532         (setq company-point (point))
 533         (company-enable-overriding-keymap company-active-map)
 534         (company-call-frontends 'update))
 535     (company-cancel)))
 536
 537 (defun company-cancel ()
 538   (setq company-backend nil
 539         company-prefix nil
 540         company-candidates nil
 541         company-candidates-length nil
 542         company-candidates-cache nil
 543         company-candidates-predicate nil
 544         company-common nil
 545         company-selection 0
 546         company-selection-changed nil
 547         company-point nil)
 548   (when company-timer
 549     (cancel-timer company-timer))
 550   (company-search-mode 0)
 551   (company-call-frontends 'hide)
 552   (company-enable-overriding-keymap nil))
 553
 554 (defun company-abort ()
 555   (company-cancel)
 556   ;; Don't start again, unless started manually.
 557   (setq company-point (point)))
 558
 559 (defun company-pre-command ()
 560   (unless (eq this-command 'company-show-doc-buffer)
 561     (condition-case err
 562         (when company-candidates
 563           (company-call-frontends 'pre-command))
 564       (error (message "Company: An error occurred in pre-command")
 565              (message "%s" (error-message-string err))
 566              (company-cancel))))
 567   (when company-timer
 568     (cancel-timer company-timer))
 569   (company-uninstall-map))
 570
 571 (defun company-post-command ()
 572   (unless (eq this-command 'company-show-doc-buffer)
 573     (condition-case err
 574         (progn
 575           (unless (equal (point) company-point)
 576             (company-begin))
 577           (when company-candidates
 578             (company-call-frontends 'post-command))
 579           (when (numberp company-idle-delay)
 580             (setq company-timer
 581                   (run-with-timer company-idle-delay nil 'company-idle-begin
 582                                   (current-buffer) (selected-window)
 583                                   (buffer-chars-modified-tick) (point)))))
 584       (error (message "Company: An error occurred in post-command")
 585              (message "%s" (error-message-string err))
 586              (company-cancel))))
 587   (company-install-map))
 588
 589 ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 590
 591 (defvar company-search-string nil)
 592 (make-variable-buffer-local 'company-search-string)
 593
 594 (defvar company-search-lighter " Search: \"\"")
 595 (make-variable-buffer-local 'company-search-lighter)
 596
 597 (defvar company-search-old-map nil)
 598 (make-variable-buffer-local 'company-search-old-map)
 599
 600 (defvar company-search-old-selection 0)
 601 (make-variable-buffer-local 'company-search-old-selection)
 602
 603 (defun company-search (text lines)
 604   (let ((quoted (regexp-quote text))
 605         (i 0))
 606     (dolist (line lines)
 607       (when (string-match quoted line (length company-prefix))
 608         (return i))
 609       (incf i))))
 610
 611 (defun company-search-printing-char ()
 612   (interactive)
 613   (unless company-mode (error "Company not enabled"))
 614   (unless company-search-mode (error "Company not in search mode"))
 615   (setq company-search-string
 616         (concat (or company-search-string "") (string last-command-event))
 617         company-search-lighter (concat " Search: \"" company-search-string
 618                                         "\""))
 619   (let ((pos (company-search company-search-string
 620                               (nthcdr company-selection company-candidates))))
 621     (if (null pos)
 622         (ding)
 623       (company-set-selection (+ company-selection pos) t))))
 624
 625 (defun company-search-repeat-forward ()
 626   "Repeat the incremental search in completion candidates forward."
 627   (interactive)
 628   (unless company-mode (error "Company not enabled"))
 629   (unless company-search-mode (error "Company not in search mode"))
 630   (let ((pos (company-search company-search-string
 631                               (cdr (nthcdr company-selection
 632                                            company-candidates)))))
 633     (if (null pos)
 634         (ding)
 635       (company-set-selection (+ company-selection pos 1) t))))
 636
 637 (defun company-search-repeat-backward ()
 638   "Repeat the incremental search in completion candidates backwards."
 639   (interactive)
 640   (unless company-mode (error "Company not enabled"))
 641   (unless company-search-mode (error "Company not in search mode"))
 642   (let ((pos (company-search company-search-string
 643                               (nthcdr (- company-candidates-length
 644                                          company-selection)
 645                                       (reverse company-candidates)))))
 646     (if (null pos)
 647         (ding)
 648       (company-set-selection (- company-selection pos 1) t))))
 649
 650 (defun company-create-match-predicate ()
 651   (setq company-candidates-predicate
 652         `(lambda (candidate)
 653            ,(if company-candidates-predicate
 654                 `(and (string-match ,company-search-string candidate)
 655                       (funcall ,company-candidates-predicate
 656                                candidate))
 657               `(string-match ,company-search-string candidate))))
 658   (company-update-candidates
 659    (company-apply-predicate company-candidates company-candidates-predicate)))
 660
 661 (defun company-filter-printing-char ()
 662   (interactive)
 663   (unless company-mode (error "Company not enabled"))
 664   (unless company-search-mode (error "Company not in search mode"))
 665   (company-search-printing-char)
 666   (company-create-match-predicate)
 667   (company-call-frontends 'update))
 668
 669 (defun company-search-kill-others ()
 670   "Limit the completion candidates to the ones matching the search string."
 671   (interactive)
 672   (unless company-mode (error "Company not enabled"))
 673   (unless company-search-mode (error "Company not in search mode"))
 674   (company-create-match-predicate)
 675   (company-search-mode 0)
 676   (company-call-frontends 'update))
 677
 678 (defun company-search-abort ()
 679   "Abort searching the completion candidates."
 680   (interactive)
 681   (unless company-mode (error "Company not enabled"))
 682   (unless company-search-mode (error "Company not in search mode"))
 683   (company-set-selection company-search-old-selection t)
 684   (company-search-mode 0))
 685
 686 (defun company-search-other-char ()
 687   (interactive)
 688   (unless company-mode (error "Company not enabled"))
 689   (unless company-search-mode (error "Company not in search mode"))
 690   (company-search-mode 0)
 691   (when last-input-event
 692     (clear-this-command-keys t)
 693     (setq unread-command-events (list last-input-event))))
 694
 695 (defvar company-search-map
 696   (let ((i 0)
 697         (keymap (make-keymap)))
 698     (if (fboundp 'max-char)
 699         (set-char-table-range (nth 1 keymap) (cons #x100 (max-char))
 700                               'company-search-printing-char)
 701       (with-no-warnings
 702         ;; obselete in Emacs 23
 703         (let ((l (generic-character-list))
 704               (table (nth 1 keymap)))
 705           (while l
 706             (set-char-table-default table (car l) 'company-search-printing-char)
 707             (setq l (cdr l))))))
 708     (define-key keymap [t] 'company-search-other-char)
 709     (while (< i ?\s)
 710       (define-key keymap (make-string 1 i) 'company-search-other-char)
 711       (incf i))
 712     (while (< i 256)
 713       (define-key keymap (vector i) 'company-search-printing-char)
 714       (incf i))
 715     (let ((meta-map (make-sparse-keymap)))
 716       (define-key keymap (char-to-string meta-prefix-char) meta-map)
 717       (define-key keymap [escape] meta-map))
 718     (define-key keymap (vector meta-prefix-char t) 'company-search-other-char)
 719     (define-key keymap "\e\e\e" 'company-search-other-char)
 720     (define-key keymap  [escape escape escape] 'company-search-other-char)
 721
 722     (define-key keymap "\C-g" 'company-search-abort)
 723     (define-key keymap "\C-s" 'company-search-repeat-forward)
 724     (define-key keymap "\C-r" 'company-search-repeat-backward)
 725     (define-key keymap "\C-o" 'company-search-kill-others)
 726     keymap)
 727   "Keymap used for incrementally searching the completion candidates.")
 728
 729 (define-minor-mode company-search-mode
 730   "Search mode for completion candidates.
 731 Don't start this directly, use `company-search-candidates' or
 732 `company-filter-candidates'."
 733   nil company-search-lighter nil
 734   (if company-search-mode
 735       (if (company-manual-begin)
 736           (progn
 737             (setq company-search-old-selection company-selection)
 738             (company-call-frontends 'update))
 739         (setq company-search-mode nil))
 740     (kill-local-variable 'company-search-string)
 741     (kill-local-variable 'company-search-lighter)
 742     (kill-local-variable 'company-search-old-selection)
 743     (company-enable-overriding-keymap company-active-map)))
 744
 745 (defun company-search-candidates ()
 746   "Start searching the completion candidates incrementally.
 747
 748 \\<company-search-map>Search can be controlled with the commands:
 749 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
 750 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
 751 - `company-search-abort' (\\[company-search-abort])
 752
 753 Regular characters are appended to the search string.
 754
 755 The command `company-search-kill-others' (\\[company-search-kill-others]) uses
 756  the search string to limit the completion candidates."
 757   (interactive)
 758   (company-search-mode 1)
 759   (company-enable-overriding-keymap company-search-map))
 760
 761 (defvar company-filter-map
 762   (let ((keymap (make-keymap)))
 763     (define-key keymap [remap company-search-printing-char]
 764       'company-filter-printing-char)
 765     (set-keymap-parent keymap company-search-map)
 766     keymap)
 767   "Keymap used for incrementally searching the completion candidates.")
 768
 769 (defun company-filter-candidates ()
 770   "Start filtering the completion candidates incrementally.
 771 This works the same way as `company-search-candidates' immediately
 772 followed by `company-search-kill-others' after each input."
 773   (interactive)
 774   (company-search-mode 1)
 775   (company-enable-overriding-keymap company-filter-map))
 776
 777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 778
 779 (defun company-select-next ()
 780   "Select the next candidate in the list."
 781   (interactive)
 782   (when (company-manual-begin)
 783     (company-set-selection (1+ company-selection))))
 784
 785 (defun company-select-previous ()
 786   "Select the previous candidate in the list."
 787   (interactive)
 788   (when (company-manual-begin)
 789     (company-set-selection (1- company-selection))))
 790
 791 (defun company-complete-selection ()
 792   "Complete the selected candidate."
 793   (interactive)
 794   (when (company-manual-begin)
 795     (insert (company-strip-prefix (nth company-selection company-candidates)))
 796     (company-abort)))
 797
 798 (defun company-complete-common ()
 799   "Complete the common part of all candidates."
 800   (interactive)
 801   (when (company-manual-begin)
 802     (insert (company-strip-prefix company-common))))
 803
 804 (defun company-complete ()
 805   "Complete the common part of all candidates or the current selection.
 806 The first time this is called, the common part is completed, the second time, or
 807 when the selection has been changed, the selected candidate is completed."
 808   (interactive)
 809   (when (company-manual-begin)
 810     (if (or company-selection-changed
 811             (eq last-command 'company-complete-common))
 812         (call-interactively 'company-complete-selection)
 813       (call-interactively 'company-complete-common)
 814       (setq this-command 'company-complete-common))))
 815
 816 (defun company-complete-number (n)
 817   "Complete the Nth candidate."
 818   (when (company-manual-begin)
 819     (and (< n 1) (> n company-candidates-length)
 820          (error "No candidate number %d" n))
 821     (decf n)
 822     (insert (company-strip-prefix (nth n company-candidates)))
 823     (company-abort)))
 824
 825 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 826
 827 (defconst company-space-strings-limit 100)
 828
 829 (defconst company-space-strings
 830   (let (lst)
 831     (dotimes (i company-space-strings-limit)
 832       (push (make-string (- company-space-strings-limit 1 i) ?\  ) lst))
 833     (apply 'vector lst)))
 834
 835 (defsubst company-space-string (len)
 836   (if (< len company-space-strings-limit)
 837       (aref company-space-strings len)
 838     (make-string len ?\ )))
 839
 840 (defsubst company-safe-substring (str from &optional to)
 841   (let ((len (length str)))
 842     (if (> from len)
 843         ""
 844       (if (and to (> to len))
 845           (concat (substring str from)
 846                   (company-space-string (- to len)))
 847         (substring str from to)))))
 848
 849 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 850
 851 (defvar company-last-metadata nil)
 852 (make-variable-buffer-local 'company-last-metadata)
 853
 854 (defun company-fetch-metadata ()
 855   (let ((selected (nth company-selection company-candidates)))
 856     (unless (equal selected (car company-last-metadata))
 857       (setq company-last-metadata
 858             (cons selected (funcall company-backend 'meta selected))))
 859     (cdr company-last-metadata)))
 860
 861 (defun company-doc-buffer (&optional string)
 862   (with-current-buffer (get-buffer-create "*Company meta-data*")
 863     (erase-buffer)
 864     (current-buffer)))
 865
 866 (defun company-show-doc-buffer ()
 867   "Temporarily show a buffer with the complete documentation for the selection."
 868   (interactive)
 869   (unless company-mode (error "Company not enabled"))
 870   (when (company-manual-begin)
 871     (save-window-excursion
 872       (let* ((height (window-height))
 873              (row (cdr (posn-col-row (posn-at-point))))
 874              (selected (nth company-selection company-candidates))
 875              (buffer (funcall company-backend 'doc-buffer selected)))
 876         (if (not buffer)
 877             (error "No documentation available.")
 878           (display-buffer buffer)
 879           (and (< (window-height) height)
 880                (< (- (window-height) row 2) company-tooltip-limit)
 881                (recenter (- (window-height) row 2)))
 882           (while (eq 'scroll-other-window
 883                      (key-binding (vector (list (read-event)))))
 884             (scroll-other-window))
 885           (when last-input-event
 886             (clear-this-command-keys t)
 887             (setq unread-command-events (list last-input-event))))))))
 888
 889 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 890
 891 (defvar company-pseudo-tooltip-overlay nil)
 892 (make-variable-buffer-local 'company-pseudo-tooltip-overlay)
 893
 894 (defvar company-tooltip-offset 0)
 895 (make-variable-buffer-local 'company-tooltip-offset)
 896
 897 (defun company-pseudo-tooltip-update-offset (selection num-lines limit)
 898
 899   (decf limit 2)
 900   (setq company-tooltip-offset
 901         (max (min selection company-tooltip-offset)
 902              (- selection -1 limit)))
 903
 904   (when (<= company-tooltip-offset 1)
 905     (incf limit)
 906     (setq company-tooltip-offset 0))
 907
 908   (when (>= company-tooltip-offset (- num-lines limit 1))
 909     (incf limit)
 910     (when (= selection (1- num-lines))
 911       (decf company-tooltip-offset)
 912       (when (<= company-tooltip-offset 1)
 913         (setq company-tooltip-offset 0)
 914         (incf limit))))
 915
 916   limit)
 917
 918 ;;; propertize
 919
 920 (defsubst company-round-tab (arg)
 921   (* (/ (+ arg tab-width) tab-width) tab-width))
 922
 923 (defun company-untabify (str)
 924   (let* ((pieces (split-string str "\t"))
 925          (copy pieces))
 926     (while (cdr copy)
 927       (setcar copy (company-safe-substring
 928                     (car copy) 0 (company-round-tab (string-width (car copy)))))
 929       (pop copy))
 930     (apply 'concat pieces)))
 931
 932 (defun company-fill-propertize (line width selected)
 933   (setq line (company-safe-substring line 0 width))
 934   (add-text-properties 0 width (list 'face 'company-tooltip) line)
 935   (add-text-properties 0 (length company-common)
 936                        (list 'face 'company-tooltip-common) line)
 937   (when selected
 938     (if (and company-search-string
 939              (string-match (regexp-quote company-search-string) line
 940                            (length company-prefix)))
 941         (progn
 942           (add-text-properties (match-beginning 0) (match-end 0)
 943                                '(face company-tooltip-selection) line)
 944           (when (< (match-beginning 0) (length company-common))
 945             (add-text-properties (match-beginning 0) (length company-common)
 946                                  '(face company-tooltip-common-selection)
 947                                  line)))
 948       (add-text-properties 0 width '(face company-tooltip-selection) line)
 949       (add-text-properties 0 (length company-common)
 950                            (list 'face 'company-tooltip-common-selection)
 951                            line)))
 952   line)
 953
 954 ;;; replace
 955
 956 (defun company-buffer-lines (beg end)
 957   (goto-char beg)
 958   (let ((row (cdr (posn-col-row (posn-at-point))))
 959         lines)
 960     (while (and (equal (move-to-window-line (incf row)) row)
 961                 (<= (point) end))
 962       (push (buffer-substring beg (min end (1- (point)))) lines)
 963       (setq beg (point)))
 964     (unless (eq beg end)
 965       (push (buffer-substring beg end) lines))
 966     (nreverse lines)))
 967
 968 (defsubst company-modify-line (old new offset)
 969   (concat (company-safe-substring old 0 offset)
 970           new
 971           (company-safe-substring old (+ offset (length new)))))
 972
 973 (defun company-replacement-string (old lines column nl)
 974   (let (new)
 975     ;; Inject into old lines.
 976     (while old
 977       (push (company-modify-line (pop old) (pop lines) column) new))
 978     ;; Append whole new lines.
 979     (while lines
 980       (push (concat (company-space-string column) (pop lines)) new))
 981     (concat (when nl "\n")
 982             (mapconcat 'identity (nreverse new) "\n")
 983             "\n")))
 984
 985 (defun company-create-lines (column selection limit)
 986
 987   (let ((len company-candidates-length)
 988         (numbered 99999)
 989         lines
 990         width
 991         lines-copy
 992         previous
 993         remainder
 994         new)
 995
 996     ;; Scroll to offset.
 997     (setq limit (company-pseudo-tooltip-update-offset selection len limit))
 998
 999     (when (> company-tooltip-offset 0)
1000       (setq previous (format "...(%d)" company-tooltip-offset)))
1001
1002     (setq remainder (- len limit company-tooltip-offset)
1003           remainder (when (> remainder 0)
1004                       (setq remainder (format "...(%d)" remainder))))
1005
1006     (decf selection company-tooltip-offset)
1007     (setq width (min (length previous) (length remainder))
1008           lines (nthcdr company-tooltip-offset company-candidates)
1009           len (min limit len)
1010           lines-copy lines)
1011
1012     (dotimes (i len)
1013       (setq width (max (length (pop lines-copy)) width)))
1014     (setq width (min width (- (window-width) column)))
1015
1016     (setq lines-copy lines)
1017
1018     ;; number can make tooltip too long
1019     (and company-show-numbers
1020          (< (setq numbered company-tooltip-offset) 10)
1021          (incf width 2))
1022
1023     (when previous
1024       (push (propertize (company-safe-substring previous 0 width)
1025                         'face 'company-tooltip)
1026             new))
1027
1028     (dotimes (i len)
1029       (push (company-fill-propertize
1030              (if (>= numbered 10)
1031                  (company-reformat (pop lines))
1032                (incf numbered)
1033                (format "%s %d"
1034                        (company-safe-substring (company-reformat (pop lines))
1035                                                0 (- width 2))
1036                        (mod numbered 10)))
1037              width (equal i selection))
1038             new))
1039
1040     (when remainder
1041       (push (propertize (company-safe-substring remainder 0 width)
1042                         'face 'company-tooltip)
1043             new))
1044
1045     (setq lines (nreverse new))))
1046
1047 ;; show
1048
1049 (defsubst company-pseudo-tooltip-height ()
1050   "Calculate the appropriate tooltip height."
1051   (max 3 (min company-tooltip-limit
1052               (- (window-height) 2
1053                  (count-lines (window-start) (point-at-bol))))))
1054
1055 (defun company-pseudo-tooltip-show (row column selection)
1056   (company-pseudo-tooltip-hide)
1057   (save-excursion
1058
1059     (move-to-column 0)
1060
1061     (let* ((height (company-pseudo-tooltip-height))
1062            (lines (company-create-lines column selection height))
1063            (nl (< (move-to-window-line row) row))
1064            (beg (point))
1065            (end (save-excursion
1066                   (move-to-window-line (+ row height))
1067                   (point)))
1068            (old-string
1069             (mapcar 'company-untabify (company-buffer-lines beg end)))
1070            str)
1071
1072       (setq company-pseudo-tooltip-overlay (make-overlay beg end))
1073
1074       (overlay-put company-pseudo-tooltip-overlay 'company-old old-string)
1075       (overlay-put company-pseudo-tooltip-overlay 'company-column column)
1076       (overlay-put company-pseudo-tooltip-overlay 'company-nl nl)
1077       (overlay-put company-pseudo-tooltip-overlay 'company-before
1078                    (company-replacement-string old-string lines column nl))
1079       (overlay-put company-pseudo-tooltip-overlay 'company-height height)
1080
1081       (overlay-put company-pseudo-tooltip-overlay 'window (selected-window)))))
1082
1083 (defun company-pseudo-tooltip-show-at-point (pos)
1084   (let ((col-row (posn-col-row (posn-at-point pos))))
1085     (company-pseudo-tooltip-show (1+ (cdr col-row)) (car col-row) company-selection)))
1086
1087 (defun company-pseudo-tooltip-edit (lines selection)
1088   (let* ((old-string (overlay-get company-pseudo-tooltip-overlay 'company-old))
1089          (column (overlay-get company-pseudo-tooltip-overlay 'company-column))
1090          (nl (overlay-get company-pseudo-tooltip-overlay 'company-nl))
1091          (height (overlay-get company-pseudo-tooltip-overlay 'company-height))
1092          (lines (company-create-lines column selection height)))
1093     (overlay-put company-pseudo-tooltip-overlay 'company-before
1094                  (company-replacement-string old-string lines column nl))))
1095
1096 (defun company-pseudo-tooltip-hide ()
1097   (when company-pseudo-tooltip-overlay
1098     (delete-overlay company-pseudo-tooltip-overlay)
1099     (setq company-pseudo-tooltip-overlay nil)))
1100
1101 (defun company-pseudo-tooltip-hide-temporarily ()
1102   (when (overlayp company-pseudo-tooltip-overlay)
1103     (overlay-put company-pseudo-tooltip-overlay 'invisible nil)
1104     (overlay-put company-pseudo-tooltip-overlay 'before-string nil)))
1105
1106 (defun company-pseudo-tooltip-unhide ()
1107   (when company-pseudo-tooltip-overlay
1108     (overlay-put company-pseudo-tooltip-overlay 'invisible t)
1109     (overlay-put company-pseudo-tooltip-overlay 'before-string
1110                  (overlay-get company-pseudo-tooltip-overlay 'company-before))
1111     (overlay-put company-pseudo-tooltip-overlay 'window (selected-window))))
1112
1113 (defun company-pseudo-tooltip-frontend (command)
1114   "A `company-mode' front-end similar to a tool-tip but based on overlays."
1115   (case command
1116     ('pre-command (company-pseudo-tooltip-hide-temporarily))
1117     ('post-command
1118      (unless (and (overlayp company-pseudo-tooltip-overlay)
1119                   (equal (overlay-get company-pseudo-tooltip-overlay
1120                                       'company-height)
1121                          (company-pseudo-tooltip-height)))
1122        ;; Redraw needed.
1123        (company-pseudo-tooltip-show-at-point (- (point)
1124                                                 (length company-prefix))))
1125      (company-pseudo-tooltip-unhide))
1126     ('hide (company-pseudo-tooltip-hide)
1127            (setq company-tooltip-offset 0))
1128     ('update (when (overlayp company-pseudo-tooltip-overlay)
1129                (company-pseudo-tooltip-edit company-candidates
1130                                             company-selection)))))
1131
1132 (defun company-pseudo-tooltip-unless-just-one-frontend (command)
1133   "`company-pseudo-tooltip-frontend', but not shown for single candidates."
1134   (unless (and (eq command 'post-command)
1135                (not (cdr company-candidates)))
1136     (company-pseudo-tooltip-frontend command)))
1137
1138 ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1139
1140 (defvar company-preview-overlay nil)
1141 (make-variable-buffer-local 'company-preview-overlay)
1142
1143 (defun company-preview-show-at-point (pos)
1144   (company-preview-hide)
1145
1146   (setq company-preview-overlay (make-overlay pos pos))
1147
1148   (let ((completion (company-strip-prefix (nth company-selection
1149                                                company-candidates))))
1150     (and (equal pos (point))
1151          (not (equal completion ""))
1152          (add-text-properties 0 1 '(cursor t) completion))
1153
1154     (setq completion (propertize completion 'face 'company-preview))
1155     (add-text-properties 0 (- (length company-common) (length company-prefix))
1156                          '(face company-preview-common) completion)
1157
1158     (overlay-put company-preview-overlay 'after-string completion)
1159     (overlay-put company-preview-overlay 'window (selected-window))))
1160
1161 (defun company-preview-hide ()
1162   (when company-preview-overlay
1163     (delete-overlay company-preview-overlay)
1164     (setq company-preview-overlay nil)))
1165
1166 (defun company-preview-frontend (command)
1167   "A `company-mode' front-end showing the selection as if it had been inserted."
1168   (case command
1169     ('pre-command (company-preview-hide))
1170     ('post-command (company-preview-show-at-point (point)))
1171     ('hide (company-preview-hide))))
1172
1173 (defun company-preview-if-just-one-frontend (command)
1174   "`company-preview-frontend', but only shown for single candidates."
1175   (unless (and (eq command 'post-command)
1176                (cdr company-candidates))
1177     (company-preview-frontend command)))
1178
1179 ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1180
1181 (defvar company-echo-last-msg nil)
1182 (make-variable-buffer-local 'company-echo-last-msg)
1183
1184 (defvar company-echo-timer nil)
1185
1186 (defvar company-echo-delay .1)
1187
1188 (defun company-echo-show (&optional getter)
1189   (when getter
1190     (setq company-echo-last-msg (funcall getter)))
1191   (let ((message-log-max nil))
1192     (if company-echo-last-msg
1193         (message "%s" company-echo-last-msg)
1194       (message ""))))
1195
1196 (defsubst company-echo-show-soon (&optional getter)
1197   (when company-echo-timer
1198     (cancel-timer company-echo-timer))
1199   (setq company-echo-timer (run-with-timer company-echo-delay nil
1200                                            'company-echo-show getter)))
1201
1202 (defun company-echo-format ()
1203
1204   (let ((limit (window-width (minibuffer-window)))
1205         (len -1)
1206         ;; Roll to selection.
1207         (candidates (nthcdr company-selection company-candidates))
1208         (i (if company-show-numbers company-selection 99999))
1209         comp msg)
1210
1211     (while candidates
1212       (setq comp (company-reformat (pop candidates))
1213             len (+ len 1 (length comp)))
1214       (if (< i 10)
1215           ;; Add number.
1216           (progn
1217             (setq comp (propertize (format "%d: %s" i comp)
1218                                    'face 'company-echo))
1219             (incf len 3)
1220             (incf i)
1221             (add-text-properties 3 (+ 3 (length company-common))
1222                                  '(face company-echo-common) comp))
1223         (setq comp (propertize comp 'face 'company-echo))
1224         (add-text-properties 0 (length company-common)
1225                              '(face company-echo-common) comp))
1226       (if (>= len limit)
1227           (setq candidates nil)
1228         (push comp msg)))
1229
1230     (mapconcat 'identity (nreverse msg) " ")))
1231
1232 (defun company-echo-strip-common-format ()
1233
1234   (let ((limit (window-width (minibuffer-window)))
1235         (len (+ (length company-prefix) 2))
1236         ;; Roll to selection.
1237         (candidates (nthcdr company-selection company-candidates))
1238         (i (if company-show-numbers company-selection 99999))
1239         msg comp)
1240
1241     (while candidates
1242       (setq comp (company-strip-prefix (pop candidates))
1243             len (+ len 2 (length comp)))
1244       (when (< i 10)
1245         ;; Add number.
1246         (setq comp (format "%s (%d)" comp i))
1247         (incf len 4)
1248         (incf i))
1249       (if (>= len limit)
1250           (setq candidates nil)
1251         (push (propertize comp 'face 'company-echo) msg)))
1252
1253     (concat (propertize company-prefix 'face 'company-echo-common) "{"
1254             (mapconcat 'identity (nreverse msg) ", ")
1255             "}")))
1256
1257 (defun company-echo-hide ()
1258   (when company-echo-timer
1259     (cancel-timer company-echo-timer))
1260   (unless (equal company-echo-last-msg "")
1261     (setq company-echo-last-msg "")
1262     (company-echo-show)))
1263
1264 (defun company-echo-frontend (command)
1265   "A `company-mode' front-end showing the candidates in the echo area."
1266   (case command
1267     ('pre-command (company-echo-show-soon))
1268     ('post-command (company-echo-show-soon 'company-echo-format))
1269     ('hide (company-echo-hide))))
1270
1271 (defun company-echo-strip-common-frontend (command)
1272   "A `company-mode' front-end showing the candidates in the echo area."
1273   (case command
1274     ('pre-command (company-echo-show-soon))
1275     ('post-command (company-echo-show-soon 'company-echo-strip-common-format))
1276     ('hide (company-echo-hide))))
1277
1278 (defun company-echo-metadata-frontend (command)
1279   "A `company-mode' front-end showing the documentation in the echo area."
1280   (case command
1281     ('pre-command (company-echo-show-soon))
1282     ('post-command (company-echo-show-soon 'company-fetch-metadata))
1283     ('hide (company-echo-hide))))
1284
1285 (provide 'company)
1286 ;;; company.el ends here