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