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