code.delx.au - gnu-emacs-elpa/blob - company.el

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