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