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) 'isearch-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   "Start searching the completion candidates incrementally.
 731
 732 \\<company-search-map>Search can be controlled with the commands:
 733 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
 734 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
 735 - `company-search-abort' (\\[company-search-abort])
 736
 737 Regular characters are appended to the search string.
 738
 739 The command `company-search-kill-others' (\\[company-search-kill-others]) uses
 740  the search string to limit the completion candidates."
 741   nil company-search-lighter nil
 742   (if company-search-mode
 743       (if (company-manual-begin)
 744           (progn
 745             (setq company-search-old-selection company-selection)
 746             (company-call-frontends 'update))
 747         (setq company-search-mode nil))
 748     (kill-local-variable 'company-search-string)
 749     (kill-local-variable 'company-search-lighter)
 750     (kill-local-variable 'company-search-old-selection)
 751     (company-enable-overriding-keymap company-active-map)))
 752
 753 (defun company-search-candidates ()
 754   "Start searching the completion candidates incrementally.
 755
 756 \\<company-search-map>Search can be controlled with the commands:
 757 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
 758 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
 759 - `company-search-abort' (\\[company-search-abort])
 760
 761 Regular characters are appended to the search string.
 762
 763 The command `company-search-kill-others' (\\[company-search-kill-others]) uses
 764  the search string to limit the completion candidates."
 765   (interactive)
 766   (company-search-mode 1)
 767   (company-enable-overriding-keymap company-search-map))
 768
 769 (defvar company-filter-map
 770   (let ((keymap (make-keymap)))
 771     (define-key keymap [remap company-search-printing-char]
 772       'company-filter-printing-char)
 773     (set-keymap-parent keymap company-search-map)
 774     keymap)
 775   "Keymap used for incrementally searching the completion candidates.")
 776
 777 (defun company-filter-candidates ()
 778   "Start filtering the completion candidates incrementally.
 779 This works the same way as `company-search-candidates' immediately
 780 followed by `company-search-kill-others' after each input."
 781   (interactive)
 782   (company-search-mode 1)
 783   (company-enable-overriding-keymap company-filter-map))
 784
 785 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 786
 787 (defun company-select-next ()
 788   "Select the next candidate in the list."
 789   (interactive)
 790   (when (company-manual-begin)
 791     (company-set-selection (1+ company-selection))))
 792
 793 (defun company-select-previous ()
 794   "Select the previous candidate in the list."
 795   (interactive)
 796   (when (company-manual-begin)
 797     (company-set-selection (1- company-selection))))
 798
 799 (defun company-complete-selection ()
 800   "Complete the selected candidate."
 801   (interactive)
 802   (when (company-manual-begin)
 803     (insert (company-strip-prefix (nth company-selection company-candidates)))
 804     (company-abort)))
 805
 806 (defun company-complete-common ()
 807   "Complete the common part of all candidates."
 808   (interactive)
 809   (when (company-manual-begin)
 810     (insert (company-strip-prefix company-common))))
 811
 812 (defun company-complete ()
 813   "Complete the common part of all candidates or the current selection.
 814 The first time this is called, the common part is completed, the second time, or
 815 when the selection has been changed, the selected candidate is completed."
 816   (interactive)
 817   (when (company-manual-begin)
 818     (if (or company-selection-changed
 819             (eq last-command 'company-complete-common))
 820         (call-interactively 'company-complete-selection)
 821       (call-interactively 'company-complete-common)
 822       (setq this-command 'company-complete-common))))
 823
 824 (defun company-complete-number (n)
 825   "Complete the Nth candidate."
 826   (when (company-manual-begin)
 827     (and (< n 1) (> n company-candidates-length)
 828          (error "No candidate number %d" n))
 829     (decf n)
 830     (insert (company-strip-prefix (nth n company-candidates)))
 831     (company-abort)))
 832
 833 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 834
 835 (defconst company-space-strings-limit 100)
 836
 837 (defconst company-space-strings
 838   (let (lst)
 839     (dotimes (i company-space-strings-limit)
 840       (push (make-string (- company-space-strings-limit 1 i) ?\  ) lst))
 841     (apply 'vector lst)))
 842
 843 (defsubst company-space-string (len)
 844   (if (< len company-space-strings-limit)
 845       (aref company-space-strings len)
 846     (make-string len ?\ )))
 847
 848 (defsubst company-safe-substring (str from &optional to)
 849   (let ((len (length str)))
 850     (if (> from len)
 851         ""
 852       (if (and to (> to len))
 853           (concat (substring str from)
 854                   (company-space-string (- to len)))
 855         (substring str from to)))))
 856
 857 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 858
 859 (defvar company-last-metadata nil)
 860 (make-variable-buffer-local 'company-last-metadata)
 861
 862 (defun company-fetch-metadata ()
 863   (let ((selected (nth company-selection company-candidates)))
 864     (unless (equal selected (car company-last-metadata))
 865       (setq company-last-metadata
 866             (cons selected (funcall company-backend 'meta selected))))
 867     (cdr company-last-metadata)))
 868
 869 (defun company-doc-buffer (&optional string)
 870   (with-current-buffer (get-buffer-create "*Company meta-data*")
 871     (erase-buffer)
 872     (current-buffer)))
 873
 874 (defun company-show-doc-buffer ()
 875   "Temporarily show a buffer with the complete documentation for the selection."
 876   (interactive)
 877   (unless company-mode (error "Company not enabled"))
 878   (when (company-manual-begin)
 879     (save-window-excursion
 880       (let* ((height (window-height))
 881              (row (cdr (posn-col-row (posn-at-point))))
 882              (selected (nth company-selection company-candidates))
 883              (buffer (funcall company-backend 'doc-buffer selected)))
 884         (if (not buffer)
 885             (error "No documentation available.")
 886           (display-buffer buffer)
 887           (and (< (window-height) height)
 888                (< (- (window-height) row 2) company-tooltip-limit)
 889                (recenter (- (window-height) row 2)))
 890           (while (eq 'scroll-other-window
 891                      (key-binding (vector (list (read-event)))))
 892             (scroll-other-window))
 893           (when last-input-event
 894             (clear-this-command-keys t)
 895             (setq unread-command-events (list last-input-event))))))))
 896
 897 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 898
 899 (defvar company-pseudo-tooltip-overlay nil)
 900 (make-variable-buffer-local 'company-pseudo-tooltip-overlay)
 901
 902 (defvar company-tooltip-offset 0)
 903 (make-variable-buffer-local 'company-tooltip-offset)
 904
 905 (defun company-pseudo-tooltip-update-offset (selection num-lines limit)
 906
 907   (decf limit 2)
 908   (setq company-tooltip-offset
 909         (max (min selection company-tooltip-offset)
 910              (- selection -1 limit)))
 911
 912   (when (<= company-tooltip-offset 1)
 913     (incf limit)
 914     (setq company-tooltip-offset 0))
 915
 916   (when (>= company-tooltip-offset (- num-lines limit 1))
 917     (incf limit)
 918     (when (= selection (1- num-lines))
 919       (decf company-tooltip-offset)
 920       (when (<= company-tooltip-offset 1)
 921         (setq company-tooltip-offset 0)
 922         (incf limit))))
 923
 924   limit)
 925
 926 ;;; propertize
 927
 928 (defsubst company-round-tab (arg)
 929   (* (/ (+ arg tab-width) tab-width) tab-width))
 930
 931 (defun company-untabify (str)
 932   (let* ((pieces (split-string str "\t"))
 933          (copy pieces))
 934     (while (cdr copy)
 935       (setcar copy (company-safe-substring
 936                     (car copy) 0 (company-round-tab (string-width (car copy)))))
 937       (pop copy))
 938     (apply 'concat pieces)))
 939
 940 (defun company-fill-propertize (line width selected)
 941   (setq line (company-safe-substring line 0 width))
 942   (add-text-properties 0 width (list 'face 'company-tooltip) line)
 943   (add-text-properties 0 (length company-common)
 944                        (list 'face 'company-tooltip-common) line)
 945   (when selected
 946     (if (and company-search-string
 947              (string-match (regexp-quote company-search-string) line
 948                            (length company-prefix)))
 949         (progn
 950           (add-text-properties (match-beginning 0) (match-end 0)
 951                                '(face company-tooltip-selection) line)
 952           (when (< (match-beginning 0) (length company-common))
 953             (add-text-properties (match-beginning 0) (length company-common)
 954                                  '(face company-tooltip-common-selection)
 955                                  line)))
 956       (add-text-properties 0 width '(face company-tooltip-selection) line)
 957       (add-text-properties 0 (length company-common)
 958                            (list 'face 'company-tooltip-common-selection)
 959                            line)))
 960   line)
 961
 962 ;;; replace
 963
 964 (defun company-buffer-lines (beg end)
 965   (goto-char beg)
 966   (let ((row (cdr (posn-col-row (posn-at-point))))
 967         lines)
 968     (while (and (equal (move-to-window-line (incf row)) row)
 969                 (<= (point) end))
 970       (push (buffer-substring beg (min end (1- (point)))) lines)
 971       (setq beg (point)))
 972     (unless (eq beg end)
 973       (push (buffer-substring beg end) lines))
 974     (nreverse lines)))
 975
 976 (defsubst company-modify-line (old new offset)
 977   (concat (company-safe-substring old 0 offset)
 978           new
 979           (company-safe-substring old (+ offset (length new)))))
 980
 981 (defun company-replacement-string (old lines column nl)
 982   (let (new)
 983     ;; Inject into old lines.
 984     (while old
 985       (push (company-modify-line (pop old) (pop lines) column) new))
 986     ;; Append whole new lines.
 987     (while lines
 988       (push (concat (company-space-string column) (pop lines)) new))
 989     (concat (when nl "\n")
 990             (mapconcat 'identity (nreverse new) "\n")
 991             "\n")))
 992
 993 (defun company-create-lines (column selection limit)
 994
 995   (let ((len company-candidates-length)
 996         (numbered 99999)
 997         lines
 998         width
 999         lines-copy
1000         previous
1001         remainder
1002         new)
1003
1004     ;; Scroll to offset.
1005     (setq limit (company-pseudo-tooltip-update-offset selection len limit))
1006
1007     (when (> company-tooltip-offset 0)
1008       (setq previous (format "...(%d)" company-tooltip-offset)))
1009
1010     (setq remainder (- len limit company-tooltip-offset)
1011           remainder (when (> remainder 0)
1012                       (setq remainder (format "...(%d)" remainder))))
1013
1014     (decf selection company-tooltip-offset)
1015     (setq width (min (length previous) (length remainder))
1016           lines (nthcdr company-tooltip-offset company-candidates)
1017           len (min limit len)
1018           lines-copy lines)
1019
1020     (dotimes (i len)
1021       (setq width (max (length (pop lines-copy)) width)))
1022     (setq width (min width (- (window-width) column)))
1023
1024     (setq lines-copy lines)
1025
1026     ;; number can make tooltip too long
1027     (and company-show-numbers
1028          (< (setq numbered company-tooltip-offset) 10)
1029          (incf width 2))
1030
1031     (when previous
1032       (push (propertize (company-safe-substring previous 0 width)
1033                         'face 'company-tooltip)
1034             new))
1035
1036     (dotimes (i len)
1037       (push (company-fill-propertize
1038              (if (>= numbered 10)
1039                  (company-reformat (pop lines))
1040                (incf numbered)
1041                (format "%s %d"
1042                        (company-safe-substring (company-reformat (pop lines))
1043                                                0 (- width 2))
1044                        (mod numbered 10)))
1045              width (equal i selection))
1046             new))
1047
1048     (when remainder
1049       (push (propertize (company-safe-substring remainder 0 width)
1050                         'face 'company-tooltip)
1051             new))
1052
1053     (setq lines (nreverse new))))
1054
1055 ;; show
1056
1057 (defsubst company-pseudo-tooltip-height ()
1058   "Calculate the appropriate tooltip height."
1059   (max 3 (min company-tooltip-limit
1060               (- (window-height) 2
1061                  (count-lines (window-start) (point-at-bol))))))
1062
1063 (defun company-pseudo-tooltip-show (row column selection)
1064   (company-pseudo-tooltip-hide)
1065   (save-excursion
1066
1067     (move-to-column 0)
1068
1069     (let* ((height (company-pseudo-tooltip-height))
1070            (lines (company-create-lines column selection height))
1071            (nl (< (move-to-window-line row) row))
1072            (beg (point))
1073            (end (save-excursion
1074                   (move-to-window-line (+ row height))
1075                   (point)))
1076            (old-string
1077             (mapcar 'company-untabify (company-buffer-lines beg end)))
1078            str)
1079
1080       (setq company-pseudo-tooltip-overlay (make-overlay beg end))
1081
1082       (overlay-put company-pseudo-tooltip-overlay 'company-old old-string)
1083       (overlay-put company-pseudo-tooltip-overlay 'company-column column)
1084       (overlay-put company-pseudo-tooltip-overlay 'company-nl nl)
1085       (overlay-put company-pseudo-tooltip-overlay 'company-before
1086                    (company-replacement-string old-string lines column nl))
1087       (overlay-put company-pseudo-tooltip-overlay 'company-height height)
1088
1089       (overlay-put company-pseudo-tooltip-overlay 'window (selected-window)))))
1090
1091 (defun company-pseudo-tooltip-show-at-point (pos)
1092   (let ((col-row (posn-col-row (posn-at-point pos))))
1093     (company-pseudo-tooltip-show (1+ (cdr col-row)) (car col-row) company-selection)))
1094
1095 (defun company-pseudo-tooltip-edit (lines selection)
1096   (let* ((old-string (overlay-get company-pseudo-tooltip-overlay 'company-old))
1097          (column (overlay-get company-pseudo-tooltip-overlay 'company-column))
1098          (nl (overlay-get company-pseudo-tooltip-overlay 'company-nl))
1099          (height (overlay-get company-pseudo-tooltip-overlay 'company-height))
1100          (lines (company-create-lines column selection height)))
1101     (overlay-put company-pseudo-tooltip-overlay 'company-before
1102                  (company-replacement-string old-string lines column nl))))
1103
1104 (defun company-pseudo-tooltip-hide ()
1105   (when company-pseudo-tooltip-overlay
1106     (delete-overlay company-pseudo-tooltip-overlay)
1107     (setq company-pseudo-tooltip-overlay nil)))
1108
1109 (defun company-pseudo-tooltip-hide-temporarily ()
1110   (when (overlayp company-pseudo-tooltip-overlay)
1111     (overlay-put company-pseudo-tooltip-overlay 'invisible nil)
1112     (overlay-put company-pseudo-tooltip-overlay 'before-string nil)))
1113
1114 (defun company-pseudo-tooltip-unhide ()
1115   (when company-pseudo-tooltip-overlay
1116     (overlay-put company-pseudo-tooltip-overlay 'invisible t)
1117     (overlay-put company-pseudo-tooltip-overlay 'before-string
1118                  (overlay-get company-pseudo-tooltip-overlay 'company-before))
1119     (overlay-put company-pseudo-tooltip-overlay 'window (selected-window))))
1120
1121 (defun company-pseudo-tooltip-frontend (command)
1122   "A `company-mode' front-end similar to a tool-tip but based on overlays."
1123   (case command
1124     ('pre-command (company-pseudo-tooltip-hide-temporarily))
1125     ('post-command
1126      (unless (and (overlayp company-pseudo-tooltip-overlay)
1127                   (equal (overlay-get company-pseudo-tooltip-overlay
1128                                       'company-height)
1129                          (company-pseudo-tooltip-height)))
1130        ;; Redraw needed.
1131        (company-pseudo-tooltip-show-at-point (- (point)
1132                                                 (length company-prefix))))
1133      (company-pseudo-tooltip-unhide))
1134     ('hide (company-pseudo-tooltip-hide)
1135            (setq company-tooltip-offset 0))
1136     ('update (when (overlayp company-pseudo-tooltip-overlay)
1137                (company-pseudo-tooltip-edit company-candidates
1138                                             company-selection)))))
1139
1140 (defun company-pseudo-tooltip-unless-just-one-frontend (command)
1141   "`company-pseudo-tooltip-frontend', but not shown for single candidates."
1142   (unless (and (eq command 'post-command)
1143                (not (cdr company-candidates)))
1144     (company-pseudo-tooltip-frontend command)))
1145
1146 ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1147
1148 (defvar company-preview-overlay nil)
1149 (make-variable-buffer-local 'company-preview-overlay)
1150
1151 (defun company-preview-show-at-point (pos)
1152   (company-preview-hide)
1153
1154   (setq company-preview-overlay (make-overlay pos pos))
1155
1156   (let ((completion (company-strip-prefix (nth company-selection
1157                                                company-candidates))))
1158     (and (equal pos (point))
1159          (not (equal completion ""))
1160          (add-text-properties 0 1 '(cursor t) completion))
1161
1162     (setq completion (propertize completion 'face 'company-preview))
1163     (add-text-properties 0 (- (length company-common) (length company-prefix))
1164                          '(face company-preview-common) completion)
1165
1166     (overlay-put company-preview-overlay 'after-string completion)
1167     (overlay-put company-preview-overlay 'window (selected-window))))
1168
1169 (defun company-preview-hide ()
1170   (when company-preview-overlay
1171     (delete-overlay company-preview-overlay)
1172     (setq company-preview-overlay nil)))
1173
1174 (defun company-preview-frontend (command)
1175   "A `company-mode' front-end showing the selection as if it had been inserted."
1176   (case command
1177     ('pre-command (company-preview-hide))
1178     ('post-command (company-preview-show-at-point (point)))
1179     ('hide (company-preview-hide))))
1180
1181 (defun company-preview-if-just-one-frontend (command)
1182   "`company-preview-frontend', but only shown for single candidates."
1183   (unless (and (eq command 'post-command)
1184                (cdr company-candidates))
1185     (company-preview-frontend command)))
1186
1187 ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1188
1189 (defvar company-echo-last-msg nil)
1190 (make-variable-buffer-local 'company-echo-last-msg)
1191
1192 (defvar company-echo-timer nil)
1193
1194 (defvar company-echo-delay .1)
1195
1196 (defun company-echo-show (&optional getter)
1197   (when getter
1198     (setq company-echo-last-msg (funcall getter)))
1199   (let ((message-log-max nil))
1200     (if company-echo-last-msg
1201         (message "%s" company-echo-last-msg)
1202       (message ""))))
1203
1204 (defsubst company-echo-show-soon (&optional getter)
1205   (when company-echo-timer
1206     (cancel-timer company-echo-timer))
1207   (setq company-echo-timer (run-with-timer company-echo-delay nil
1208                                            'company-echo-show getter)))
1209
1210 (defun company-echo-format ()
1211
1212   (let ((limit (window-width (minibuffer-window)))
1213         (len -1)
1214         ;; Roll to selection.
1215         (candidates (nthcdr company-selection company-candidates))
1216         (i (if company-show-numbers company-selection 99999))
1217         comp msg)
1218
1219     (while candidates
1220       (setq comp (company-reformat (pop candidates))
1221             len (+ len 1 (length comp)))
1222       (if (< i 10)
1223           ;; Add number.
1224           (progn
1225             (setq comp (propertize (format "%d: %s" i comp)
1226                                    'face 'company-echo))
1227             (incf len 3)
1228             (incf i)
1229             (add-text-properties 3 (+ 3 (length company-common))
1230                                  '(face company-echo-common) comp))
1231         (setq comp (propertize comp 'face 'company-echo))
1232         (add-text-properties 0 (length company-common)
1233                              '(face company-echo-common) comp))
1234       (if (>= len limit)
1235           (setq candidates nil)
1236         (push comp msg)))
1237
1238     (mapconcat 'identity (nreverse msg) " ")))
1239
1240 (defun company-echo-strip-common-format ()
1241
1242   (let ((limit (window-width (minibuffer-window)))
1243         (len (+ (length company-prefix) 2))
1244         ;; Roll to selection.
1245         (candidates (nthcdr company-selection company-candidates))
1246         (i (if company-show-numbers company-selection 99999))
1247         msg comp)
1248
1249     (while candidates
1250       (setq comp (company-strip-prefix (pop candidates))
1251             len (+ len 2 (length comp)))
1252       (when (< i 10)
1253         ;; Add number.
1254         (setq comp (format "%s (%d)" comp i))
1255         (incf len 4)
1256         (incf i))
1257       (if (>= len limit)
1258           (setq candidates nil)
1259         (push (propertize comp 'face 'company-echo) msg)))
1260
1261     (concat (propertize company-prefix 'face 'company-echo-common) "{"
1262             (mapconcat 'identity (nreverse msg) ", ")
1263             "}")))
1264
1265 (defun company-echo-hide ()
1266   (when company-echo-timer
1267     (cancel-timer company-echo-timer))
1268   (unless (equal company-echo-last-msg "")
1269     (setq company-echo-last-msg "")
1270     (company-echo-show)))
1271
1272 (defun company-echo-frontend (command)
1273   "A `company-mode' front-end showing the candidates in the echo area."
1274   (case command
1275     ('pre-command (company-echo-show-soon))
1276     ('post-command (company-echo-show-soon 'company-echo-format))
1277     ('hide (company-echo-hide))))
1278
1279 (defun company-echo-strip-common-frontend (command)
1280   "A `company-mode' front-end showing the candidates in the echo area."
1281   (case command
1282     ('pre-command (company-echo-show-soon))
1283     ('post-command (company-echo-show-soon 'company-echo-strip-common-format))
1284     ('hide (company-echo-hide))))
1285
1286 (defun company-echo-metadata-frontend (command)
1287   "A `company-mode' front-end showing the documentation in the echo area."
1288   (case command
1289     ('pre-command (company-echo-show-soon))
1290     ('post-command (company-echo-show-soon 'company-fetch-metadata))
1291     ('hide (company-echo-hide))))
1292
1293 (provide 'company)
1294 ;;; company.el ends here