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