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