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