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

   1 ;;; company.el --- Modular text completion framework  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2009-2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Nikolaj Schumacher
   6 ;; Maintainer: Dmitry Gutov <dgutov@yandex.ru>
   7 ;; URL: http://company-mode.github.io/
   8 ;; Version: 0.9.0-cvs
   9 ;; Keywords: abbrev, convenience, matching
  10 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; Company is a modular completion mechanism.  Modules for retrieving completion
  30 ;; candidates are called backends, modules for displaying them are frontends.
  31 ;;
  32 ;; Company comes with many backends, e.g. `company-elisp'.  These are
  33 ;; distributed in separate files and can be used individually.
  34 ;;
  35 ;; Place company.el and the backends you want to use in a directory and add the
  36 ;; following to your .emacs:
  37 ;; (add-to-list 'load-path "/path/to/company")
  38 ;; (autoload 'company-mode "company" nil t)
  39 ;;
  40 ;; Enable company-mode with M-x company-mode.  For further information look at
  41 ;; the documentation for `company-mode' (C-h f company-mode RET)
  42 ;;
  43 ;; If you want to start a specific backend, call it interactively or use
  44 ;; `company-begin-backend'.  For example:
  45 ;; M-x company-abbrev will prompt for and insert an abbrev.
  46 ;;
  47 ;; To write your own backend, look at the documentation for `company-backends'.
  48 ;; Here is a simple example completing "foo":
  49 ;;
  50 ;; (defun company-my-backend (command &optional arg &rest ignored)
  51 ;;   (pcase command
  52 ;;     (`prefix (when (looking-back "foo\\>")
  53 ;;               (match-string 0)))
  54 ;;     (`candidates (list "foobar" "foobaz" "foobarbaz"))
  55 ;;     (`meta (format "This value is named %s" arg))))
  56 ;;
  57 ;; Sometimes it is a good idea to mix several backends together, for example to
  58 ;; enrich gtags with dabbrev-code results (to emulate local variables).
  59 ;; To do this, add a list with both backends as an element in company-backends.
  60 ;;
  61 ;;; Change Log:
  62 ;;
  63 ;; See NEWS.md in the repository.
  64
  65 ;;; Code:
  66
  67 (require 'cl-lib)
  68 (require 'newcomment)
  69
  70 ;; FIXME: Use `user-error'.
  71 (add-to-list 'debug-ignored-errors "^.* frontend cannot be used twice$")
  72 (add-to-list 'debug-ignored-errors "^Echo area cannot be used twice$")
  73 (add-to-list 'debug-ignored-errors "^No \\(document\\|loc\\)ation available$")
  74 (add-to-list 'debug-ignored-errors "^Company not ")
  75 (add-to-list 'debug-ignored-errors "^No candidate number ")
  76 (add-to-list 'debug-ignored-errors "^Cannot complete at point$")
  77 (add-to-list 'debug-ignored-errors "^No other backend$")
  78
  79 ;;; Compatibility
  80 (eval-and-compile
  81   ;; `defvar-local' for Emacs 24.2 and below
  82   (unless (fboundp 'defvar-local)
  83     (defmacro defvar-local (var val &optional docstring)
  84       "Define VAR as a buffer-local variable with default value VAL.
  85 Like `defvar' but additionally marks the variable as being automatically
  86 buffer-local wherever it is set."
  87       (declare (debug defvar) (doc-string 3))
  88       `(progn
  89          (defvar ,var ,val ,docstring)
  90          (make-variable-buffer-local ',var)))))
  91
  92 (defgroup company nil
  93   "Extensible inline text completion mechanism"
  94   :group 'abbrev
  95   :group 'convenience
  96   :group 'matching)
  97
  98 (defface company-tooltip
  99   '((default :foreground "black")
 100     (((class color) (min-colors 88) (background light))
 101      (:background "cornsilk"))
 102     (((class color) (min-colors 88) (background dark))
 103      (:background "yellow")))
 104   "Face used for the tooltip.")
 105
 106 (defface company-tooltip-selection
 107   '((default :inherit company-tooltip)
 108     (((class color) (min-colors 88) (background light))
 109      (:background "light blue"))
 110     (((class color) (min-colors 88) (background dark))
 111      (:background "orange1"))
 112     (t (:background "green")))
 113   "Face used for the selection in the tooltip.")
 114
 115 (defface company-tooltip-search
 116   '((default :inherit company-tooltip-selection))
 117   "Face used for the search string in the tooltip.")
 118
 119 (defface company-tooltip-mouse
 120   '((default :inherit highlight))
 121   "Face used for the tooltip item under the mouse.")
 122
 123 (defface company-tooltip-common
 124   '((default :inherit company-tooltip)
 125     (((background light))
 126      :foreground "darkred")
 127     (((background dark))
 128      :foreground "red"))
 129   "Face used for the common completion in the tooltip.")
 130
 131 (defface company-tooltip-common-selection
 132   '((default :inherit company-tooltip-selection)
 133     (((background light))
 134      :foreground "darkred")
 135     (((background dark))
 136      :foreground "red"))
 137   "Face used for the selected common completion in the tooltip.")
 138
 139 (defface company-tooltip-annotation
 140   '((default :inherit company-tooltip)
 141     (((background light))
 142      :foreground "firebrick4")
 143     (((background dark))
 144      :foreground "red4"))
 145   "Face used for the annotation in the tooltip.")
 146
 147 (defface company-scrollbar-fg
 148   '((((background light))
 149      :background "darkred")
 150     (((background dark))
 151      :background "red"))
 152   "Face used for the tooltip scrollbar thumb.")
 153
 154 (defface company-scrollbar-bg
 155   '((default :inherit company-tooltip)
 156     (((background light))
 157      :background "wheat")
 158     (((background dark))
 159      :background "gold"))
 160   "Face used for the tooltip scrollbar background.")
 161
 162 (defface company-preview
 163   '((((background light))
 164      :inherit company-tooltip-selection)
 165     (((background dark))
 166      :background "blue4"
 167      :foreground "wheat"))
 168   "Face used for the completion preview.")
 169
 170 (defface company-preview-common
 171   '((((background light))
 172      :inherit company-tooltip-selection)
 173     (((background dark))
 174      :inherit company-preview
 175      :foreground "red"))
 176   "Face used for the common part of the completion preview.")
 177
 178 (defface company-preview-search
 179   '((((background light))
 180      :inherit company-tooltip-common-selection)
 181     (((background dark))
 182      :inherit company-preview
 183      :background "blue1"))
 184   "Face used for the search string in the completion preview.")
 185
 186 (defface company-echo nil
 187   "Face used for completions in the echo area.")
 188
 189 (defface company-echo-common
 190   '((((background dark)) (:foreground "firebrick1"))
 191     (((background light)) (:background "firebrick4")))
 192   "Face used for the common part of completions in the echo area.")
 193
 194 (defun company-frontends-set (variable value)
 195   ;; Uniquify.
 196   (let ((value (delete-dups (copy-sequence value))))
 197     (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
 198          (memq 'company-pseudo-tooltip-frontend value)
 199          (error "Pseudo tooltip frontend cannot be used twice"))
 200     (and (memq 'company-preview-if-just-one-frontend value)
 201          (memq 'company-preview-frontend value)
 202          (error "Preview frontend cannot be used twice"))
 203     (and (memq 'company-echo value)
 204          (memq 'company-echo-metadata-frontend value)
 205          (error "Echo area cannot be used twice"))
 206     ;; Preview must come last.
 207     (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend))
 208       (when (cdr (memq f value))
 209         (setq value (append (delq f value) (list f)))))
 210     (set variable value)))
 211
 212 (defcustom company-frontends '(company-pseudo-tooltip-unless-just-one-frontend
 213                                company-preview-if-just-one-frontend
 214                                company-echo-metadata-frontend)
 215   "The list of active frontends (visualizations).
 216 Each frontend is a function that takes one argument.  It is called with
 217 one of the following arguments:
 218
 219 `show': When the visualization should start.
 220
 221 `hide': When the visualization should end.
 222
 223 `update': When the data has been updated.
 224
 225 `pre-command': Before every command that is executed while the
 226 visualization is active.
 227
 228 `post-command': After every command that is executed while the
 229 visualization is active.
 230
 231 The visualized data is stored in `company-prefix', `company-candidates',
 232 `company-common', `company-selection', `company-point' and
 233 `company-search-string'."
 234   :set 'company-frontends-set
 235   :type '(repeat (choice (const :tag "echo" company-echo-frontend)
 236                          (const :tag "echo, strip common"
 237                                 company-echo-strip-common-frontend)
 238                          (const :tag "show echo meta-data in echo"
 239                                 company-echo-metadata-frontend)
 240                          (const :tag "pseudo tooltip"
 241                                 company-pseudo-tooltip-frontend)
 242                          (const :tag "pseudo tooltip, multiple only"
 243                                 company-pseudo-tooltip-unless-just-one-frontend)
 244                          (const :tag "preview" company-preview-frontend)
 245                          (const :tag "preview, unique only"
 246                                 company-preview-if-just-one-frontend)
 247                          (function :tag "custom function" nil))))
 248
 249 (defcustom company-tooltip-limit 10
 250   "The maximum number of candidates in the tooltip."
 251   :type 'integer)
 252
 253 (defcustom company-tooltip-minimum 6
 254   "The minimum height of the tooltip.
 255 If this many lines are not available, prefer to display the tooltip above."
 256   :type 'integer)
 257
 258 (defcustom company-tooltip-minimum-width 0
 259   "The minimum width of the tooltip's inner area.
 260 This doesn't include the margins and the scroll bar."
 261   :type 'integer
 262   :package-version '(company . "0.8.0"))
 263
 264 (defcustom company-tooltip-margin 1
 265   "Width of margin columns to show around the toolip."
 266   :type 'integer)
 267
 268 (defcustom company-tooltip-offset-display 'scrollbar
 269   "Method using which the tooltip displays scrolling position.
 270 `scrollbar' means draw a scrollbar to the right of the items.
 271 `lines' means wrap items in lines with \"before\" and \"after\" counters."
 272   :type '(choice (const :tag "Scrollbar" scrollbar)
 273                  (const :tag "Two lines" lines)))
 274
 275 (defcustom company-tooltip-align-annotations nil
 276   "When non-nil, align annotations to the right tooltip border."
 277   :type 'boolean
 278   :package-version '(company . "0.7.1"))
 279
 280 (defcustom company-tooltip-flip-when-above nil
 281   "Whether to flip the tooltip when it's above the current line."
 282   :type 'boolean
 283   :package-version '(company . "0.8.1"))
 284
 285 (defvar company-safe-backends
 286   '((company-abbrev . "Abbrev")
 287     (company-bbdb . "BBDB")
 288     (company-capf . "completion-at-point-functions")
 289     (company-clang . "Clang")
 290     (company-cmake . "CMake")
 291     (company-css . "CSS")
 292     (company-dabbrev . "dabbrev for plain text")
 293     (company-dabbrev-code . "dabbrev for code")
 294     (company-eclim . "Eclim (an Eclipse interface)")
 295     (company-elisp . "Emacs Lisp")
 296     (company-etags . "etags")
 297     (company-files . "Files")
 298     (company-gtags . "GNU Global")
 299     (company-ispell . "Ispell")
 300     (company-keywords . "Programming language keywords")
 301     (company-nxml . "nxml")
 302     (company-oddmuse . "Oddmuse")
 303     (company-semantic . "Semantic")
 304     (company-tempo . "Tempo templates")
 305     (company-xcode . "Xcode")))
 306 (put 'company-safe-backends 'risky-local-variable t)
 307
 308 (defun company-safe-backends-p (backends)
 309   (and (consp backends)
 310        (not (cl-dolist (backend backends)
 311               (unless (if (consp backend)
 312                           (company-safe-backends-p backend)
 313                         (assq backend company-safe-backends))
 314                 (cl-return t))))))
 315
 316 (defcustom company-backends `(,@(unless (version< "24.3.51" emacs-version)
 317                                   (list 'company-elisp))
 318                               company-bbdb
 319                               company-nxml company-css
 320                               company-eclim company-semantic company-clang
 321                               company-xcode company-cmake
 322                               company-capf
 323                               (company-dabbrev-code company-gtags company-etags
 324                                company-keywords)
 325                               company-oddmuse company-files company-dabbrev)
 326   "The list of active backends (completion engines).
 327
 328 Only one backend is used at a time.  The choice depends on the order of
 329 the items in this list, and on the values they return in response to the
 330 `prefix' command (see below).  But a backend can also be a \"grouped\"
 331 one (see below).
 332
 333 `company-begin-backend' can be used to start a specific backend,
 334 `company-other-backend' will skip to the next matching backend in the list.
 335
 336 Each backend is a function that takes a variable number of arguments.
 337 The first argument is the command requested from the backend.  It is one
 338 of the following:
 339
 340 `prefix': The backend should return the text to be completed.  It must be
 341 text immediately before point.  Returning nil from this command passes
 342 control to the next backend.  The function should return `stop' if it
 343 should complete but cannot (e.g. if it is in the middle of a string).
 344 Instead of a string, the backend may return a cons where car is the prefix
 345 and cdr is used instead of the actual prefix length in the comparison
 346 against `company-minimum-prefix-length'.  It must be either number or t,
 347 and in the latter case the test automatically succeeds.
 348
 349 `candidates': The second argument is the prefix to be completed.  The
 350 return value should be a list of candidates that match the prefix.
 351
 352 Non-prefix matches are also supported (candidates that don't start with the
 353 prefix, but match it in some backend-defined way).  Backends that use this
 354 feature must disable cache (return t to `no-cache') and might also want to
 355 respond to `match'.
 356
 357 Optional commands
 358 =================
 359
 360 `sorted': Return t here to indicate that the candidates are sorted and will
 361 not need to be sorted again.
 362
 363 `duplicates': If non-nil, company will take care of removing duplicates
 364 from the list.
 365
 366 `no-cache': Usually company doesn't ask for candidates again as completion
 367 progresses, unless the backend returns t for this command.  The second
 368 argument is the latest prefix.
 369
 370 `ignore-case': Return t here if the backend returns case-insensitive
 371 matches.  This value is used to determine the longest common prefix (as
 372 used in `company-complete-common'), and to filter completions when fetching
 373 them from cache.
 374
 375 `meta': The second argument is a completion candidate.  Return a (short)
 376 documentation string for it.
 377
 378 `doc-buffer': The second argument is a completion candidate.  Return a
 379 buffer with documentation for it.  Preferably use `company-doc-buffer'.  If
 380 not all buffer contents pertain to this candidate, return a cons of buffer
 381 and window start position.
 382
 383 `location': The second argument is a completion candidate.  Return a cons
 384 of buffer and buffer location, or of file and line number where the
 385 completion candidate was defined.
 386
 387 `annotation': The second argument is a completion candidate.  Return a
 388 string to be displayed inline with the candidate in the popup.  If
 389 duplicates are removed by company, candidates with equal string values will
 390 be kept if they have different annotations.  For that to work properly,
 391 backends should store the related information on candidates using text
 392 properties.
 393
 394 `match': The second argument is a completion candidate.  Return the index
 395 after the end of text matching `prefix' within the candidate string.  It
 396 will be used when rendering the popup.  This command only makes sense for
 397 backends that provide non-prefix completion.
 398
 399 `require-match': If this returns t, the user is not allowed to enter
 400 anything not offered as a candidate.  Please don't use that value in normal
 401 backends.  The default value nil gives the user that choice with
 402 `company-require-match'.  Return value `never' overrides that option the
 403 other way around.
 404
 405 `init': Called once for each buffer. The backend can check for external
 406 programs and files and load any required libraries.  Raising an error here
 407 will show up in message log once, and the backend will not be used for
 408 completion.
 409
 410 `post-completion': Called after a completion candidate has been inserted
 411 into the buffer.  The second argument is the candidate.  Can be used to
 412 modify it, e.g. to expand a snippet.
 413
 414 The backend should return nil for all commands it does not support or
 415 does not know about.  It should also be callable interactively and use
 416 `company-begin-backend' to start itself in that case.
 417
 418 Grouped backends
 419 ================
 420
 421 An element of `company-backends' can also be a list of backends.  The
 422 completions from backends in such groups are merged, but only from those
 423 backends which return the same `prefix'.
 424
 425 Whenever makes sense, company commands taking a candidate as an argument
 426 are dispatched to the backend it came from.  In other cases, the first
 427 non-nil value among all the backends is returned.
 428
 429 The group can also contain keywords. Currently, `:with' and `:sorted'
 430 keywords are defined. If the group contains keyword `:with' , the backends
 431 listed after this keyword are ignored for the purpose of `prefix'
 432 command. If a grouped backend contains keyword `:sorted', the
 433 final (merged) list of candidates is not sorted.
 434
 435 Asynchronous backends
 436 =====================
 437
 438 The return value of each command can also be a cons (:async . FETCHER)
 439 where FETCHER is a function of one argument, CALLBACK.  When the data
 440 arrives, FETCHER must call CALLBACK and pass it the appropriate return
 441 value, as described above.
 442
 443 True asynchronous operation is only supported for command `candidates', and
 444 only during idle completion.  Other commands will block the user interface,
 445 even if the backend uses the asynchronous calling convention."
 446   :type `(repeat
 447           (choice
 448            :tag "backend"
 449            ,@(mapcar (lambda (b) `(const :tag ,(cdr b) ,(car b)))
 450                      company-safe-backends)
 451            (symbol :tag "User defined")
 452            (repeat :tag "Merged backends"
 453                    (choice :tag "backend"
 454                            ,@(mapcar (lambda (b)
 455                                        `(const :tag ,(cdr b) ,(car b)))
 456                                      company-safe-backends)
 457                            (const :tag "With" :with)
 458                            (symbol :tag "User defined"))))))
 459
 460 (put 'company-backends 'safe-local-variable 'company-safe-backends-p)
 461
 462 (defcustom company-transformers nil
 463   "Functions to change the list of candidates received from backends.
 464
 465 Each function gets called with the return value of the previous one.
 466 The first one gets passed the list of candidates, already sorted and
 467 without duplicates."
 468   :type '(choice
 469           (const :tag "None" nil)
 470           (const :tag "Sort by occurrence" (company-sort-by-occurrence))
 471           (const :tag "Sort by backend importance"
 472                  (company-sort-by-backend-importance))
 473           (repeat :tag "User defined" (function))))
 474
 475 (defcustom company-completion-started-hook nil
 476   "Hook run when company starts completing.
 477 The hook is called with one argument that is non-nil if the completion was
 478 started manually."
 479   :type 'hook)
 480
 481 (defcustom company-completion-cancelled-hook nil
 482   "Hook run when company cancels completing.
 483 The hook is called with one argument that is non-nil if the completion was
 484 aborted manually."
 485   :type 'hook)
 486
 487 (defcustom company-completion-finished-hook nil
 488   "Hook run when company successfully completes.
 489 The hook is called with the selected candidate as an argument.
 490
 491 If you indend to use it to post-process candidates from a specific
 492 backend, consider using the `post-completion' command instead."
 493   :type 'hook)
 494
 495 (defcustom company-minimum-prefix-length 3
 496   "The minimum prefix length for idle completion."
 497   :type '(integer :tag "prefix length"))
 498
 499 (defcustom company-abort-manual-when-too-short nil
 500   "If enabled, cancel a manually started completion when the prefix gets
 501 shorter than both `company-minimum-prefix-length' and the length of the
 502 prefix it was started from."
 503   :type 'boolean
 504   :package-version '(company . "0.8.0"))
 505
 506 (defcustom company-require-match 'company-explicit-action-p
 507   "If enabled, disallow non-matching input.
 508 This can be a function do determine if a match is required.
 509
 510 This can be overridden by the backend, if it returns t or `never' to
 511 `require-match'.  `company-auto-complete' also takes precedence over this."
 512   :type '(choice (const :tag "Off" nil)
 513                  (function :tag "Predicate function")
 514                  (const :tag "On, if user interaction took place"
 515                         'company-explicit-action-p)
 516                  (const :tag "On" t)))
 517
 518 (defcustom company-auto-complete nil
 519   "Determines when to auto-complete.
 520 If this is enabled, all characters from `company-auto-complete-chars'
 521 trigger insertion of the selected completion candidate.
 522 This can also be a function."
 523   :type '(choice (const :tag "Off" nil)
 524                  (function :tag "Predicate function")
 525                  (const :tag "On, if user interaction took place"
 526                         'company-explicit-action-p)
 527                  (const :tag "On" t)))
 528
 529 (defcustom company-auto-complete-chars '(?\  ?\) ?.)
 530   "Determines which characters trigger auto-completion.
 531 See `company-auto-complete'.  If this is a string, each string character
 532 tiggers auto-completion.  If it is a list of syntax description characters (see
 533 `modify-syntax-entry'), all characters with that syntax auto-complete.
 534
 535 This can also be a function, which is called with the new input and should
 536 return non-nil if company should auto-complete.
 537
 538 A character that is part of a valid candidate never triggers auto-completion."
 539   :type '(choice (string :tag "Characters")
 540                  (set :tag "Syntax"
 541                       (const :tag "Whitespace" ?\ )
 542                       (const :tag "Symbol" ?_)
 543                       (const :tag "Opening parentheses" ?\()
 544                       (const :tag "Closing parentheses" ?\))
 545                       (const :tag "Word constituent" ?w)
 546                       (const :tag "Punctuation." ?.)
 547                       (const :tag "String quote." ?\")
 548                       (const :tag "Paired delimiter." ?$)
 549                       (const :tag "Expression quote or prefix operator." ?\')
 550                       (const :tag "Comment starter." ?<)
 551                       (const :tag "Comment ender." ?>)
 552                       (const :tag "Character-quote." ?/)
 553                       (const :tag "Generic string fence." ?|)
 554                       (const :tag "Generic comment fence." ?!))
 555                  (function :tag "Predicate function")))
 556
 557 (defcustom company-idle-delay .5
 558   "The idle delay in seconds until completion starts automatically.
 559 The prefix still has to satisfy `company-minimum-prefix-length' before that
 560 happens.  The value of nil means no idle completion."
 561   :type '(choice (const :tag "never (nil)" nil)
 562                  (const :tag "immediate (0)" 0)
 563                  (number :tag "seconds")))
 564
 565 (defcustom company-begin-commands '(self-insert-command
 566                                     org-self-insert-command
 567                                     orgtbl-self-insert-command
 568                                     c-scope-operator
 569                                     c-electric-colon
 570                                     c-electric-lt-gt
 571                                     c-electric-slash)
 572   "A list of commands after which idle completion is allowed.
 573 If this is t, it can show completions after any command except a few from a
 574 pre-defined list.  See `company-idle-delay'.
 575
 576 Alternatively, any command with a non-nil `company-begin' property is
 577 treated as if it was on this list."
 578   :type '(choice (const :tag "Any command" t)
 579                  (const :tag "Self insert command" '(self-insert-command))
 580                  (repeat :tag "Commands" function))
 581   :package-version '(company . "0.8.4"))
 582
 583 (defcustom company-continue-commands '(not save-buffer save-some-buffers
 584                                            save-buffers-kill-terminal
 585                                            save-buffers-kill-emacs)
 586   "A list of commands that are allowed during completion.
 587 If this is t, or if `company-begin-commands' is t, any command is allowed.
 588 Otherwise, the value must be a list of symbols.  If it starts with `not',
 589 the cdr is the list of commands that abort completion.  Otherwise, all
 590 commands except those in that list, or in `company-begin-commands', or
 591 commands in the `company-' namespace, abort completion."
 592   :type '(choice (const :tag "Any command" t)
 593                  (cons  :tag "Any except"
 594                         (const not)
 595                         (repeat :tag "Commands" function))
 596                  (repeat :tag "Commands" function)))
 597
 598 (defcustom company-show-numbers nil
 599   "If enabled, show quick-access numbers for the first ten candidates."
 600   :type '(choice (const :tag "off" nil)
 601                  (const :tag "on" t)))
 602
 603 (defcustom company-selection-wrap-around nil
 604   "If enabled, selecting item before first or after last wraps around."
 605   :type '(choice (const :tag "off" nil)
 606                  (const :tag "on" t)))
 607
 608 (defvar company-async-wait 0.03
 609   "Pause between checks to see if the value's been set when turning an
 610 asynchronous call into synchronous.")
 611
 612 (defvar company-async-timeout 2
 613   "Maximum wait time for a value to be set during asynchronous call.")
 614
 615 ;;; mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 616
 617 (defvar company-mode-map (make-sparse-keymap)
 618   "Keymap used by `company-mode'.")
 619
 620 (defvar company-active-map
 621   (let ((keymap (make-sparse-keymap)))
 622     (define-key keymap "\e\e\e" 'company-abort)
 623     (define-key keymap "\C-g" 'company-abort)
 624     (define-key keymap (kbd "M-n") 'company-select-next)
 625     (define-key keymap (kbd "M-p") 'company-select-previous)
 626     (define-key keymap (kbd "<down>") 'company-select-next-or-abort)
 627     (define-key keymap (kbd "<up>") 'company-select-previous-or-abort)
 628     (define-key keymap [remap scroll-up-command] 'company-next-page)
 629     (define-key keymap [remap scroll-down-command] 'company-previous-page)
 630     (define-key keymap [down-mouse-1] 'ignore)
 631     (define-key keymap [down-mouse-3] 'ignore)
 632     (define-key keymap [mouse-1] 'company-complete-mouse)
 633     (define-key keymap [mouse-3] 'company-select-mouse)
 634     (define-key keymap [up-mouse-1] 'ignore)
 635     (define-key keymap [up-mouse-3] 'ignore)
 636     (define-key keymap [return] 'company-complete-selection)
 637     (define-key keymap (kbd "RET") 'company-complete-selection)
 638     (define-key keymap [tab] 'company-complete-common)
 639     (define-key keymap (kbd "TAB") 'company-complete-common)
 640     (define-key keymap (kbd "<f1>") 'company-show-doc-buffer)
 641     (define-key keymap (kbd "C-h") 'company-show-doc-buffer)
 642     (define-key keymap "\C-w" 'company-show-location)
 643     (define-key keymap "\C-s" 'company-search-candidates)
 644     (define-key keymap "\C-\M-s" 'company-filter-candidates)
 645     (dotimes (i 10)
 646       (define-key keymap (read-kbd-macro (format "M-%d" i)) 'company-complete-number))
 647      keymap)
 648   "Keymap that is enabled during an active completion.")
 649
 650 (defvar company--disabled-backends nil)
 651
 652 (defun company-init-backend (backend)
 653   (and (symbolp backend)
 654        (not (fboundp backend))
 655        (ignore-errors (require backend nil t)))
 656   (cond
 657    ((symbolp backend)
 658     (condition-case err
 659         (progn
 660           (funcall backend 'init)
 661           (put backend 'company-init t))
 662       (error
 663        (put backend 'company-init 'failed)
 664        (unless (memq backend company--disabled-backends)
 665          (message "Company backend '%s' could not be initialized:\n%s"
 666                   backend (error-message-string err)))
 667        (cl-pushnew backend company--disabled-backends)
 668        nil)))
 669    ;; No initialization for lambdas.
 670    ((functionp backend) t)
 671    (t ;; Must be a list.
 672     (cl-dolist (b backend)
 673       (unless (keywordp b)
 674         (company-init-backend b))))))
 675
 676 (defcustom company-lighter-base "company"
 677   "Base string to use for the `company-mode' lighter."
 678   :type 'string
 679   :package-version '(company . "0.8.10"))
 680
 681 (defvar company-lighter '(" "
 682                           (company-candidates
 683                            (:eval
 684                             (if (consp company-backend)
 685                                 (company--group-lighter (nth company-selection
 686                                                              company-candidates)
 687                                                         company-lighter-base)
 688                               (symbol-name company-backend)))
 689                            company-lighter-base))
 690   "Mode line lighter for Company.
 691
 692 The value of this variable is a mode line template as in
 693 `mode-line-format'.")
 694
 695 (put 'company-lighter 'risky-local-variable t)
 696
 697 ;;;###autoload
 698 (define-minor-mode company-mode
 699   "\"complete anything\"; is an in-buffer completion framework.
 700 Completion starts automatically, depending on the values
 701 `company-idle-delay' and `company-minimum-prefix-length'.
 702
 703 Completion can be controlled with the commands:
 704 `company-complete-common', `company-complete-selection', `company-complete',
 705 `company-select-next', `company-select-previous'.  If these commands are
 706 called before `company-idle-delay', completion will also start.
 707
 708 Completions can be searched with `company-search-candidates' or
 709 `company-filter-candidates'.  These can be used while completion is
 710 inactive, as well.
 711
 712 The completion data is retrieved using `company-backends' and displayed
 713 using `company-frontends'.  If you want to start a specific backend, call
 714 it interactively or use `company-begin-backend'.
 715
 716 By default, the completions list is sorted alphabetically, unless the
 717 backend chooses otherwise, or `company-transformers' changes it later.
 718
 719 regular keymap (`company-mode-map'):
 720
 721 \\{company-mode-map}
 722 keymap during active completions (`company-active-map'):
 723
 724 \\{company-active-map}"
 725   nil company-lighter company-mode-map
 726   (if company-mode
 727       (progn
 728         (when (eq company-idle-delay t)
 729           (setq company-idle-delay 0)
 730           (warn "Setting `company-idle-delay' to t is deprecated.  Set it to 0 instead."))
 731         (add-hook 'pre-command-hook 'company-pre-command nil t)
 732         (add-hook 'post-command-hook 'company-post-command nil t)
 733         (mapc 'company-init-backend company-backends))
 734     (remove-hook 'pre-command-hook 'company-pre-command t)
 735     (remove-hook 'post-command-hook 'company-post-command t)
 736     (company-cancel)
 737     (kill-local-variable 'company-point)))
 738
 739 (defcustom company-global-modes t
 740   "Modes for which `company-mode' mode is turned on by `global-company-mode'.
 741 If nil, means no modes.  If t, then all major modes have it turned on.
 742 If a list, it should be a list of `major-mode' symbol names for which
 743 `company-mode' should be automatically turned on.  The sense of the list is
 744 negated if it begins with `not'.  For example:
 745  (c-mode c++-mode)
 746 means that `company-mode' is turned on for buffers in C and C++ modes only.
 747  (not message-mode)
 748 means that `company-mode' is always turned on except in `message-mode' buffers."
 749   :type '(choice (const :tag "none" nil)
 750                  (const :tag "all" t)
 751                  (set :menu-tag "mode specific" :tag "modes"
 752                       :value (not)
 753                       (const :tag "Except" not)
 754                       (repeat :inline t (symbol :tag "mode")))))
 755
 756 ;;;###autoload
 757 (define-globalized-minor-mode global-company-mode company-mode company-mode-on)
 758
 759 (defun company-mode-on ()
 760   (when (and (not (or noninteractive (eq (aref (buffer-name) 0) ?\s)))
 761              (cond ((eq company-global-modes t)
 762                     t)
 763                    ((eq (car-safe company-global-modes) 'not)
 764                     (not (memq major-mode (cdr company-global-modes))))
 765                    (t (memq major-mode company-global-modes))))
 766     (company-mode 1)))
 767
 768 (defsubst company-assert-enabled ()
 769   (unless company-mode
 770     (company-uninstall-map)
 771     (error "Company not enabled")))
 772
 773 ;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 774
 775 (defvar-local company-my-keymap nil)
 776
 777 (defvar company-emulation-alist '((t . nil)))
 778
 779 (defsubst company-enable-overriding-keymap (keymap)
 780   (company-uninstall-map)
 781   (setq company-my-keymap keymap))
 782
 783 (defun company-ensure-emulation-alist ()
 784   (unless (eq 'company-emulation-alist (car emulation-mode-map-alists))
 785     (setq emulation-mode-map-alists
 786           (cons 'company-emulation-alist
 787                 (delq 'company-emulation-alist emulation-mode-map-alists)))))
 788
 789 (defun company-install-map ()
 790   (unless (or (cdar company-emulation-alist)
 791               (null company-my-keymap))
 792     (setf (cdar company-emulation-alist) company-my-keymap)))
 793
 794 (defun company-uninstall-map ()
 795   (setf (cdar company-emulation-alist) nil))
 796
 797 ;; Hack:
 798 ;; Emacs calculates the active keymaps before reading the event.  That means we
 799 ;; cannot change the keymap from a timer.  So we send a bogus command.
 800 ;; XXX: Even in Emacs 24.4, seems to be needed in the terminal.
 801 (defun company-ignore ()
 802   (interactive)
 803   (setq this-command last-command))
 804
 805 (global-set-key '[company-dummy-event] 'company-ignore)
 806
 807 (defun company-input-noop ()
 808   (push 'company-dummy-event unread-command-events))
 809
 810 (defun company--posn-col-row (posn)
 811   (let ((col (car (posn-col-row posn)))
 812         ;; `posn-col-row' doesn't work well with lines of different height.
 813         ;; `posn-actual-col-row' doesn't handle multiple-width characters.
 814         (row (cdr (posn-actual-col-row posn))))
 815     (when (and header-line-format (version< emacs-version "24.3.93.3"))
 816       ;; http://debbugs.gnu.org/18384
 817       (cl-decf row))
 818     (cons (+ col (window-hscroll)) row)))
 819
 820 (defun company--col-row (&optional pos)
 821   (company--posn-col-row (posn-at-point pos)))
 822
 823 (defun company--row (&optional pos)
 824   (cdr (company--col-row pos)))
 825
 826 ;;; backends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 827
 828 (defvar-local company-backend nil)
 829
 830 (defun company-grab (regexp &optional expression limit)
 831   (when (looking-back regexp limit)
 832     (or (match-string-no-properties (or expression 0)) "")))
 833
 834 (defun company-grab-line (regexp &optional expression)
 835   (company-grab regexp expression (point-at-bol)))
 836
 837 (defun company-grab-symbol ()
 838   (if (looking-at "\\_>")
 839       (buffer-substring (point) (save-excursion (skip-syntax-backward "w_")
 840                                                 (point)))
 841     (unless (and (char-after) (memq (char-syntax (char-after)) '(?w ?_)))
 842       "")))
 843
 844 (defun company-grab-word ()
 845   (if (looking-at "\\>")
 846       (buffer-substring (point) (save-excursion (skip-syntax-backward "w")
 847                                                 (point)))
 848     (unless (and (char-after) (eq (char-syntax (char-after)) ?w))
 849       "")))
 850
 851 (defun company-grab-symbol-cons (idle-begin-after-re &optional max-len)
 852   (let ((symbol (company-grab-symbol)))
 853     (when symbol
 854       (save-excursion
 855         (forward-char (- (length symbol)))
 856         (if (looking-back idle-begin-after-re (if max-len
 857                                                   (- (point) max-len)
 858                                                 (line-beginning-position)))
 859             (cons symbol t)
 860           symbol)))))
 861
 862 (defun company-in-string-or-comment ()
 863   (let ((ppss (syntax-ppss)))
 864     (or (car (setq ppss (nthcdr 3 ppss)))
 865         (car (setq ppss (cdr ppss)))
 866         (nth 3 ppss))))
 867
 868 (defun company-call-backend (&rest args)
 869   (company--force-sync #'company-call-backend-raw args company-backend))
 870
 871 (defun company--force-sync (fun args backend)
 872   (let ((value (apply fun args)))
 873     (if (not (eq (car-safe value) :async))
 874         value
 875       (let ((res 'trash)
 876             (start (time-to-seconds)))
 877         (funcall (cdr value)
 878                  (lambda (result) (setq res result)))
 879         (while (eq res 'trash)
 880           (if (> (- (time-to-seconds) start) company-async-timeout)
 881               (error "Company: backend %s async timeout with args %s"
 882                      backend args)
 883             (sleep-for company-async-wait)))
 884         res))))
 885
 886 (defun company-call-backend-raw (&rest args)
 887   (condition-case-unless-debug err
 888       (if (functionp company-backend)
 889           (apply company-backend args)
 890         (apply #'company--multi-backend-adapter company-backend args))
 891     (error (error "Company: backend %s error \"%s\" with args %s"
 892                   company-backend (error-message-string err) args))))
 893
 894 (defun company--multi-backend-adapter (backends command &rest args)
 895   (let ((backends (cl-loop for b in backends
 896                            when (not (and (symbolp b)
 897                                           (eq 'failed (get b 'company-init))))
 898                            collect b)))
 899
 900     (when (eq command 'prefix)
 901       (setq backends (butlast backends (length (member :with backends)))))
 902
 903     (unless (memq command '(sorted))
 904       (setq backends (cl-delete-if #'keywordp backends)))
 905
 906     (pcase command
 907       (`candidates
 908        (company--multi-backend-adapter-candidates backends (car args)))
 909       (`sorted (memq :sorted backends))
 910       (`duplicates t)
 911       ((or `prefix `ignore-case `no-cache `require-match)
 912        (let (value)
 913          (cl-dolist (backend backends)
 914            (when (setq value (company--force-sync
 915                               backend (cons command args) backend))
 916              (cl-return value)))))
 917       (_
 918        (let ((arg (car args)))
 919          (when (> (length arg) 0)
 920            (let ((backend (or (get-text-property 0 'company-backend arg)
 921                               (car backends))))
 922              (apply backend command args))))))))
 923
 924 (defun company--multi-backend-adapter-candidates (backends prefix)
 925   (let ((pairs (cl-loop for backend in (cdr backends)
 926                         when (equal (company--prefix-str
 927                                      (funcall backend 'prefix))
 928                                     prefix)
 929                         collect (cons (funcall backend 'candidates prefix)
 930                                       (let ((b backend))
 931                                         (lambda (candidates)
 932                                           (mapcar
 933                                            (lambda (str)
 934                                              (propertize str 'company-backend b))
 935                                            candidates)))))))
 936     (when (equal (company--prefix-str (funcall (car backends) 'prefix)) prefix)
 937       ;; Small perf optimization: don't tag the candidates received
 938       ;; from the first backend in the group.
 939       (push (cons (funcall (car backends) 'candidates prefix)
 940                   'identity)
 941             pairs))
 942     (company--merge-async pairs (lambda (values) (apply #'append values)))))
 943
 944 (defun company--merge-async (pairs merger)
 945   (let ((async (cl-loop for pair in pairs
 946                         thereis
 947                         (eq :async (car-safe (car pair))))))
 948     (if (not async)
 949         (funcall merger (cl-loop for (val . mapper) in pairs
 950                                  collect (funcall mapper val)))
 951       (cons
 952        :async
 953        (lambda (callback)
 954          (let* (lst
 955                 (pending (mapcar #'car pairs))
 956                 (finisher (lambda ()
 957                             (unless pending
 958                               (funcall callback
 959                                        (funcall merger
 960                                                 (nreverse lst)))))))
 961            (dolist (pair pairs)
 962              (push nil lst)
 963              (let* ((cell lst)
 964                     (val (car pair))
 965                     (mapper (cdr pair))
 966                     (this-finisher (lambda (res)
 967                                      (setq pending (delq val pending))
 968                                      (setcar cell (funcall mapper res))
 969                                      (funcall finisher))))
 970                (if (not (eq :async (car-safe val)))
 971                    (funcall this-finisher val)
 972                  (let ((fetcher (cdr val)))
 973                    (funcall fetcher this-finisher)))))))))))
 974
 975 (defun company--prefix-str (prefix)
 976   (or (car-safe prefix) prefix))
 977
 978 ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 979
 980 (defvar-local company-prefix nil)
 981
 982 (defvar-local company-candidates nil)
 983
 984 (defvar-local company-candidates-length nil)
 985
 986 (defvar-local company-candidates-cache nil)
 987
 988 (defvar-local company-candidates-predicate nil)
 989
 990 (defvar-local company-common nil)
 991
 992 (defvar-local company-selection 0)
 993
 994 (defvar-local company-selection-changed nil)
 995
 996 (defvar-local company--manual-action nil
 997   "Non-nil, if manual completion took place.")
 998
 999 (defvar-local company--manual-prefix nil)
1000
1001 (defvar company--auto-completion nil
1002   "Non-nil when current candidate is being inserted automatically.
1003 Controlled by `company-auto-complete'.")
1004
1005 (defvar-local company--point-max nil)
1006
1007 (defvar-local company-point nil)
1008
1009 (defvar company-timer nil)
1010
1011 (defsubst company-strip-prefix (str)
1012   (substring str (length company-prefix)))
1013
1014 (defun company--insert-candidate (candidate)
1015   (when (> (length candidate) 0)
1016     (setq candidate (substring-no-properties candidate))
1017     ;; XXX: Return value we check here is subject to change.
1018     (if (eq (company-call-backend 'ignore-case) 'keep-prefix)
1019         (insert (company-strip-prefix candidate))
1020       (unless (equal company-prefix candidate)
1021         (delete-region (- (point) (length company-prefix)) (point))
1022         (insert candidate)))))
1023
1024 (defmacro company-with-candidate-inserted (candidate &rest body)
1025   "Evaluate BODY with CANDIDATE temporarily inserted.
1026 This is a tool for backends that need candidates inserted before they
1027 can retrieve meta-data for them."
1028   (declare (indent 1))
1029   `(let ((inhibit-modification-hooks t)
1030          (inhibit-point-motion-hooks t)
1031          (modified-p (buffer-modified-p)))
1032      (company--insert-candidate ,candidate)
1033      (unwind-protect
1034          (progn ,@body)
1035        (delete-region company-point (point))
1036        (set-buffer-modified-p modified-p))))
1037
1038 (defun company-explicit-action-p ()
1039   "Return whether explicit completion action was taken by the user."
1040   (or company--manual-action
1041       company-selection-changed))
1042
1043 (defun company-reformat (candidate)
1044   ;; company-ispell needs this, because the results are always lower-case
1045   ;; It's mory efficient to fix it only when they are displayed.
1046   ;; FIXME: Adopt the current text's capitalization instead?
1047   (if (eq (company-call-backend 'ignore-case) 'keep-prefix)
1048       (concat company-prefix (substring candidate (length company-prefix)))
1049     candidate))
1050
1051 (defun company--should-complete ()
1052   (and (eq company-idle-delay 'now)
1053        (not (or buffer-read-only overriding-terminal-local-map
1054                 overriding-local-map))
1055        ;; Check if in the middle of entering a key combination.
1056        (or (equal (this-command-keys-vector) [])
1057            (not (keymapp (key-binding (this-command-keys-vector)))))
1058        (not (and transient-mark-mode mark-active))))
1059
1060 (defun company--should-continue ()
1061   (or (eq t company-begin-commands)
1062       (eq t company-continue-commands)
1063       (if (eq 'not (car company-continue-commands))
1064           (not (memq this-command (cdr company-continue-commands)))
1065         (or (memq this-command company-begin-commands)
1066             (memq this-command company-continue-commands)
1067             (and (symbolp this-command)
1068                  (string-match-p "\\`company-" (symbol-name this-command)))))))
1069
1070 (defun company-call-frontends (command)
1071   (dolist (frontend company-frontends)
1072     (condition-case-unless-debug err
1073         (funcall frontend command)
1074       (error (error "Company: frontend %s error \"%s\" on command %s"
1075                     frontend (error-message-string err) command)))))
1076
1077 (defun company-set-selection (selection &optional force-update)
1078   (setq selection
1079         (if company-selection-wrap-around
1080             (mod selection company-candidates-length)
1081           (max 0 (min (1- company-candidates-length) selection))))
1082   (when (or force-update (not (equal selection company-selection)))
1083     (setq company-selection selection
1084           company-selection-changed t)
1085     (company-call-frontends 'update)))
1086
1087 (defun company--group-lighter (candidate base)
1088   (let ((backend (or (get-text-property 0 'company-backend candidate)
1089                      (car company-backend))))
1090     (when (and backend (symbolp backend))
1091       (let ((name (replace-regexp-in-string "company-\\|-company" ""
1092                                             (symbol-name backend))))
1093         (format "%s-<%s>" base name)))))
1094
1095 (defun company-update-candidates (candidates)
1096   (setq company-candidates-length (length candidates))
1097   (if company-selection-changed
1098       ;; Try to restore the selection
1099       (let ((selected (nth company-selection company-candidates)))
1100         (setq company-selection 0
1101               company-candidates candidates)
1102         (when selected
1103           (catch 'found
1104             (while candidates
1105               (let ((candidate (pop candidates)))
1106                 (when (and (string= candidate selected)
1107                            (equal (company-call-backend 'annotation candidate)
1108                                   (company-call-backend 'annotation selected)))
1109                   (throw 'found t)))
1110               (cl-incf company-selection))
1111             (setq company-selection 0
1112                   company-selection-changed nil))))
1113     (setq company-selection 0
1114           company-candidates candidates))
1115   ;; Calculate common.
1116   (let ((completion-ignore-case (company-call-backend 'ignore-case)))
1117     ;; We want to support non-prefix completion, so filtering is the
1118     ;; responsibility of each respective backend, not ours.
1119     ;; On the other hand, we don't want to replace non-prefix input in
1120     ;; `company-complete-common', unless there's only one candidate.
1121     (setq company-common
1122           (if (cdr company-candidates)
1123               (let ((common (try-completion "" company-candidates)))
1124                 (when (string-prefix-p company-prefix common
1125                                        completion-ignore-case)
1126                   common))
1127             (car company-candidates)))))
1128
1129 (defun company-calculate-candidates (prefix)
1130   (let ((candidates (cdr (assoc prefix company-candidates-cache)))
1131         (ignore-case (company-call-backend 'ignore-case)))
1132     (or candidates
1133         (when company-candidates-cache
1134           (let ((len (length prefix))
1135                 (completion-ignore-case ignore-case)
1136                 prev)
1137             (cl-dotimes (i (1+ len))
1138               (when (setq prev (cdr (assoc (substring prefix 0 (- len i))
1139                                            company-candidates-cache)))
1140                 (setq candidates (all-completions prefix prev))
1141                 (cl-return t)))))
1142         (progn
1143           ;; No cache match, call the backend.
1144           (setq candidates (company--preprocess-candidates
1145                             (company--fetch-candidates prefix)))
1146           ;; Save in cache.
1147           (push (cons prefix candidates) company-candidates-cache)))
1148     ;; Only now apply the predicate and transformers.
1149     (setq candidates (company--postprocess-candidates candidates))
1150     (when candidates
1151       (if (or (cdr candidates)
1152               (not (eq t (compare-strings (car candidates) nil nil
1153                                           prefix nil nil ignore-case))))
1154           candidates
1155         ;; Already completed and unique; don't start.
1156         t))))
1157
1158 (defun company--fetch-candidates (prefix)
1159   (let ((c (if company--manual-action
1160                (company-call-backend 'candidates prefix)
1161              (company-call-backend-raw 'candidates prefix)))
1162         res)
1163     (if (not (eq (car c) :async))
1164         c
1165       (let ((buf (current-buffer))
1166             (win (selected-window))
1167             (tick (buffer-chars-modified-tick))
1168             (pt (point))
1169             (backend company-backend))
1170         (funcall
1171          (cdr c)
1172          (lambda (candidates)
1173            (if (not (and candidates (eq res 'done)))
1174                ;; There's no completions to display,
1175                ;; or the fetcher called us back right away.
1176                (setq res candidates)
1177              (setq company-backend backend
1178                    company-candidates-cache
1179                    (list (cons prefix
1180                                (company--preprocess-candidates candidates))))
1181              (company-idle-begin buf win tick pt)))))
1182       ;; FIXME: Relying on the fact that the callers
1183       ;; will interpret nil as "do nothing" is shaky.
1184       ;; A throw-catch would be one possible improvement.
1185       (or res
1186           (progn (setq res 'done) nil)))))
1187
1188 (defun company--preprocess-candidates (candidates)
1189   (unless (company-call-backend 'sorted)
1190     (setq candidates (sort candidates 'string<)))
1191   (when (company-call-backend 'duplicates)
1192     (company--strip-duplicates candidates))
1193   candidates)
1194
1195 (defun company--postprocess-candidates (candidates)
1196   (when (or company-candidates-predicate company-transformers)
1197     (setq candidates (copy-sequence candidates)))
1198   (when company-candidates-predicate
1199     (setq candidates (cl-delete-if-not company-candidates-predicate candidates)))
1200   (company--transform-candidates candidates))
1201
1202 (defun company--strip-duplicates (candidates)
1203   (let ((c2 candidates)
1204         (annos 'unk))
1205     (while c2
1206       (setcdr c2
1207               (let ((str (pop c2)))
1208                 (while (let ((str2 (car c2)))
1209                          (if (not (equal str str2))
1210                              (progn
1211                                (setq annos 'unk)
1212                                nil)
1213                            (when (eq annos 'unk)
1214                              (setq annos (list (company-call-backend
1215                                                 'annotation str))))
1216                            (let ((anno2 (company-call-backend
1217                                          'annotation str2)))
1218                              (if (member anno2 annos)
1219                                  t
1220                                (push anno2 annos)
1221                                nil))))
1222                   (pop c2))
1223                 c2)))))
1224
1225 (defun company--transform-candidates (candidates)
1226   (let ((c candidates))
1227     (dolist (tr company-transformers)
1228       (setq c (funcall tr c)))
1229     c))
1230
1231 (defcustom company-occurrence-weight-function
1232   #'company-occurrence-prefer-closest-above
1233   "Function to weigh matches in `company-sort-by-occurrence'.
1234 It's called with three arguments: cursor position, the beginning and the
1235 end of the match."
1236   :type '(choice
1237           (const :tag "First above point, then below point"
1238                  company-occurrence-prefer-closest-above)
1239           (const :tag "Prefer closest in any direction"
1240                  company-occurrence-prefer-any-closest)))
1241
1242 (defun company-occurrence-prefer-closest-above (pos match-beg match-end)
1243   "Give priority to the matches above point, then those below point."
1244   (if (< match-beg pos)
1245       (- pos match-end)
1246     (- match-beg (window-start))))
1247
1248 (defun company-occurrence-prefer-any-closest (pos _match-beg match-end)
1249   "Give priority to the matches closest to the point."
1250   (abs (- pos match-end)))
1251
1252 (defun company-sort-by-occurrence (candidates)
1253   "Sort CANDIDATES according to their occurrences.
1254 Searches for each in the currently visible part of the current buffer and
1255 prioritizes the matches according to `company-occurrence-weight-function'.
1256 The rest of the list is appended unchanged.
1257 Keywords and function definition names are ignored."
1258   (let* ((w-start (window-start))
1259          (w-end (window-end))
1260          (start-point (point))
1261          occurs
1262          (noccurs
1263           (save-excursion
1264             (cl-delete-if
1265              (lambda (candidate)
1266                (when (catch 'done
1267                        (goto-char w-start)
1268                        (while (search-forward candidate w-end t)
1269                          (when (and (not (eq (point) start-point))
1270                                     (save-match-data
1271                                       (company--occurrence-predicate)))
1272                            (throw 'done t))))
1273                  (push
1274                   (cons candidate
1275                         (funcall company-occurrence-weight-function
1276                                  start-point
1277                                  (match-beginning 0)
1278                                  (match-end 0)))
1279                   occurs)
1280                  t))
1281              candidates))))
1282     (nconc
1283      (mapcar #'car (sort occurs (lambda (e1 e2) (<= (cdr e1) (cdr e2)))))
1284      noccurs)))
1285
1286 (defun company--occurrence-predicate ()
1287   (let ((beg (match-beginning 0))
1288         (end (match-end 0)))
1289     (save-excursion
1290       (goto-char end)
1291       (and (not (memq (get-text-property (1- (point)) 'face)
1292                       '(font-lock-function-name-face
1293                         font-lock-keyword-face)))
1294            (let ((prefix (company--prefix-str
1295                           (company-call-backend 'prefix))))
1296              (and (stringp prefix)
1297                   (= (length prefix) (- end beg))))))))
1298
1299 (defun company-sort-by-backend-importance (candidates)
1300   "Sort CANDIDATES as two priority groups.
1301 If `company-backend' is a function, do nothing.  If it's a list, move
1302 candidates from backends before keyword `:with' to the front.  Candidates
1303 from the rest of the backends in the group, if any, will be left at the end."
1304   (if (functionp company-backend)
1305       candidates
1306     (let ((low-priority (cdr (memq :with company-backend))))
1307       (if (null low-priority)
1308           candidates
1309         (sort candidates
1310               (lambda (c1 c2)
1311                 (and
1312                  (let ((b2 (get-text-property 0 'company-backend c2)))
1313                    (and b2 (memq b2 low-priority)))
1314                  (let ((b1 (get-text-property 0 'company-backend c1)))
1315                    (or (not b1) (not (memq b1 low-priority)))))))))))
1316
1317 (defun company-idle-begin (buf win tick pos)
1318   (and (eq buf (current-buffer))
1319        (eq win (selected-window))
1320        (eq tick (buffer-chars-modified-tick))
1321        (eq pos (point))
1322        (when (company-auto-begin)
1323          (company-input-noop)
1324          (let ((this-command 'company-idle-begin))
1325            (company-post-command)))))
1326
1327 (defun company-auto-begin ()
1328   (and company-mode
1329        (not company-candidates)
1330        (let ((company-idle-delay 'now))
1331          (condition-case-unless-debug err
1332              (progn
1333                (company--perform)
1334                ;; Return non-nil if active.
1335                company-candidates)
1336            (error (message "Company: An error occurred in auto-begin")
1337                   (message "%s" (error-message-string err))
1338                   (company-cancel))
1339            (quit (company-cancel))))))
1340
1341 (defun company-manual-begin ()
1342   (interactive)
1343   (company-assert-enabled)
1344   (setq company--manual-action t)
1345   (unwind-protect
1346       (let ((company-minimum-prefix-length 0))
1347         (or company-candidates
1348             (company-auto-begin)))
1349     (unless company-candidates
1350       (setq company--manual-action nil))))
1351
1352 (defun company-other-backend (&optional backward)
1353   (interactive (list current-prefix-arg))
1354   (company-assert-enabled)
1355   (let* ((after (if company-backend
1356                     (cdr (member company-backend company-backends))
1357                   company-backends))
1358          (before (cdr (member company-backend (reverse company-backends))))
1359          (next (if backward
1360                    (append before (reverse after))
1361                  (append after (reverse before)))))
1362     (company-cancel)
1363     (cl-dolist (backend next)
1364       (when (ignore-errors (company-begin-backend backend))
1365         (cl-return t))))
1366   (unless company-candidates
1367     (error "No other backend")))
1368
1369 (defun company-require-match-p ()
1370   (let ((backend-value (company-call-backend 'require-match)))
1371     (or (eq backend-value t)
1372         (and (not (eq backend-value 'never))
1373              (if (functionp company-require-match)
1374                  (funcall company-require-match)
1375                (eq company-require-match t))))))
1376
1377 (defun company-auto-complete-p (input)
1378   "Return non-nil, if input starts with punctuation or parentheses."
1379   (and (if (functionp company-auto-complete)
1380            (funcall company-auto-complete)
1381          company-auto-complete)
1382        (if (functionp company-auto-complete-chars)
1383            (funcall company-auto-complete-chars input)
1384          (if (consp company-auto-complete-chars)
1385              (memq (char-syntax (string-to-char input))
1386                    company-auto-complete-chars)
1387            (string-match (substring input 0 1) company-auto-complete-chars)))))
1388
1389 (defun company--incremental-p ()
1390   (and (> (point) company-point)
1391        (> (point-max) company--point-max)
1392        (not (eq this-command 'backward-delete-char-untabify))
1393        (equal (buffer-substring (- company-point (length company-prefix))
1394                                 company-point)
1395               company-prefix)))
1396
1397 (defun company--continue-failed (new-prefix)
1398   (let ((input (buffer-substring-no-properties (point) company-point)))
1399     (cond
1400      ((company-auto-complete-p input)
1401       ;; auto-complete
1402       (save-excursion
1403         (goto-char company-point)
1404         (let ((company--auto-completion t))
1405           (company-complete-selection))
1406         nil))
1407      ((and (or (not (company-require-match-p))
1408                ;; Don't require match if the new prefix
1409                ;; doesn't continue the old one, and the latter was a match.
1410                (not (stringp new-prefix))
1411                (<= (length new-prefix) (length company-prefix)))
1412            (member company-prefix company-candidates))
1413       ;; Last input was a success,
1414       ;; but we're treating it as an abort + input anyway,
1415       ;; like the `unique' case below.
1416       (company-cancel 'non-unique))
1417      ((company-require-match-p)
1418       ;; Wrong incremental input, but required match.
1419       (delete-char (- (length input)))
1420       (ding)
1421       (message "Matching input is required")
1422       company-candidates)
1423      (t (company-cancel)))))
1424
1425 (defun company--good-prefix-p (prefix)
1426   (and (stringp (company--prefix-str prefix)) ;excludes 'stop
1427        (or (eq (cdr-safe prefix) t)
1428            (let ((len (or (cdr-safe prefix) (length prefix))))
1429              (if company--manual-prefix
1430                  (or (not company-abort-manual-when-too-short)
1431                      ;; Must not be less than minimum or initial length.
1432                      (>= len (min company-minimum-prefix-length
1433                                   (length company--manual-prefix))))
1434                (>= len company-minimum-prefix-length))))))
1435
1436 (defun company--continue ()
1437   (when (company-call-backend 'no-cache company-prefix)
1438     ;; Don't complete existing candidates, fetch new ones.
1439     (setq company-candidates-cache nil))
1440   (let* ((new-prefix (company-call-backend 'prefix))
1441          (c (when (and (company--good-prefix-p new-prefix)
1442                        (setq new-prefix (company--prefix-str new-prefix))
1443                        (= (- (point) (length new-prefix))
1444                           (- company-point (length company-prefix))))
1445               (company-calculate-candidates new-prefix))))
1446     (cond
1447      ((eq c t)
1448       ;; t means complete/unique.
1449       ;; Handle it like completion was aborted, to differentiate from user
1450       ;; calling one of Company's commands to insert the candidate,
1451       ;; not to trigger template expansion, etc.
1452       (company-cancel 'unique))
1453      ((consp c)
1454       ;; incremental match
1455       (setq company-prefix new-prefix)
1456       (company-update-candidates c)
1457       c)
1458      ((not (company--incremental-p))
1459       (company-cancel))
1460      (t (company--continue-failed new-prefix)))))
1461
1462 (defun company--begin-new ()
1463   (let (prefix c)
1464     (cl-dolist (backend (if company-backend
1465                             ;; prefer manual override
1466                             (list company-backend)
1467                           company-backends))
1468       (setq prefix
1469             (if (or (symbolp backend)
1470                     (functionp backend))
1471                 (when (or (not (symbolp backend))
1472                           (eq t (get backend 'company-init))
1473                           (unless (get backend 'company-init)
1474                             (company-init-backend backend)))
1475                   (funcall backend 'prefix))
1476               (company--multi-backend-adapter backend 'prefix)))
1477       (when prefix
1478         (when (company--good-prefix-p prefix)
1479           (setq company-prefix (company--prefix-str prefix)
1480                 company-backend backend
1481                 c (company-calculate-candidates company-prefix))
1482           (if (not (consp c))
1483               (progn
1484                 (when company--manual-action
1485                   (message "No completion found"))
1486                 (when (eq c t)
1487                   ;; t means complete/unique.
1488                   ;; Run the hooks anyway, to e.g. clear the cache.
1489                   (company-cancel 'unique)))
1490             (when company--manual-action
1491               (setq company--manual-prefix prefix))
1492             (company-update-candidates c)
1493             (run-hook-with-args 'company-completion-started-hook
1494                                 (company-explicit-action-p))
1495             (company-call-frontends 'show)))
1496         (cl-return c)))))
1497
1498 (defun company--perform ()
1499   (or (and company-candidates (company--continue))
1500       (and (company--should-complete) (company--begin-new)))
1501   (if (not company-candidates)
1502       (setq company-backend nil)
1503     (setq company-point (point)
1504           company--point-max (point-max))
1505     (company-ensure-emulation-alist)
1506     (company-enable-overriding-keymap company-active-map)
1507     (company-call-frontends 'update)))
1508
1509 (defun company-cancel (&optional result)
1510   (unwind-protect
1511       (when company-prefix
1512         (if (stringp result)
1513             (progn
1514               (company-call-backend 'pre-completion result)
1515               (run-hook-with-args 'company-completion-finished-hook result)
1516               (company-call-backend 'post-completion result))
1517           (run-hook-with-args 'company-completion-cancelled-hook result)))
1518     (setq company-backend nil
1519           company-prefix nil
1520           company-candidates nil
1521           company-candidates-length nil
1522           company-candidates-cache nil
1523           company-candidates-predicate nil
1524           company-common nil
1525           company-selection 0
1526           company-selection-changed nil
1527           company--manual-action nil
1528           company--manual-prefix nil
1529           company--point-max nil
1530           company-point nil)
1531     (when company-timer
1532       (cancel-timer company-timer))
1533     (company-echo-cancel t)
1534     (company-search-mode 0)
1535     (company-call-frontends 'hide)
1536     (company-enable-overriding-keymap nil))
1537   ;; Make return value explicit.
1538   nil)
1539
1540 (defun company-abort ()
1541   (interactive)
1542   (company-cancel 'abort))
1543
1544 (defun company-finish (result)
1545   (company--insert-candidate result)
1546   (company-cancel result))
1547
1548 (defsubst company-keep (command)
1549   (and (symbolp command) (get command 'company-keep)))
1550
1551 (defun company-pre-command ()
1552   (unless (company-keep this-command)
1553     (condition-case-unless-debug err
1554         (when company-candidates
1555           (company-call-frontends 'pre-command)
1556           (unless (company--should-continue)
1557             (company-abort)))
1558       (error (message "Company: An error occurred in pre-command")
1559              (message "%s" (error-message-string err))
1560              (company-cancel))))
1561   (when company-timer
1562     (cancel-timer company-timer)
1563     (setq company-timer nil))
1564   (company-echo-cancel t)
1565   (company-uninstall-map))
1566
1567 (defun company-post-command ()
1568   (when (null this-command)
1569     ;; Happens when the user presses `C-g' while inside
1570     ;; `flyspell-post-command-hook', for example.
1571     ;; Or any other `post-command-hook' function that can call `sit-for',
1572     ;; or any quittable timer function.
1573     (company-abort)
1574     (setq this-command 'company-abort))
1575   (unless (company-keep this-command)
1576     (condition-case-unless-debug err
1577         (progn
1578           (unless (equal (point) company-point)
1579             (let (company-idle-delay) ; Against misbehavior while debugging.
1580               (company--perform)))
1581           (if company-candidates
1582               (company-call-frontends 'post-command)
1583             (and (numberp company-idle-delay)
1584                  (not defining-kbd-macro)
1585                  (company--should-begin)
1586                  (setq company-timer
1587                        (run-with-timer company-idle-delay nil
1588                                        'company-idle-begin
1589                                        (current-buffer) (selected-window)
1590                                        (buffer-chars-modified-tick) (point))))))
1591       (error (message "Company: An error occurred in post-command")
1592              (message "%s" (error-message-string err))
1593              (company-cancel))))
1594   (company-install-map))
1595
1596 (defvar company--begin-inhibit-commands '(company-abort
1597                                           company-complete-mouse
1598                                           company-complete
1599                                           company-complete-common
1600                                           company-complete-selection
1601                                           company-complete-number)
1602   "List of commands after which idle completion is (still) disabled when
1603 `company-begin-commands' is t.")
1604
1605 (defun company--should-begin ()
1606   (if (eq t company-begin-commands)
1607       (not (memq this-command company--begin-inhibit-commands))
1608     (or
1609      (memq this-command company-begin-commands)
1610      (and (symbolp this-command) (get this-command 'company-begin)))))
1611
1612 ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1613
1614 (defvar-local company-search-string "")
1615
1616 (defvar company-search-lighter '(" "
1617                                  (company-search-filtering "Filter" "Search")
1618                                  ": \""
1619                                  company-search-string
1620                                  "\""))
1621
1622 (defvar-local company-search-filtering nil
1623   "Non-nil to filter the completion candidates by the search string")
1624
1625 (defvar-local company--search-old-selection 0)
1626
1627 (defvar-local company--search-old-changed nil)
1628
1629 (defun company--search (text lines)
1630   (let ((quoted (regexp-quote text))
1631         (i 0))
1632     (cl-dolist (line lines)
1633       (when (string-match quoted line (length company-prefix))
1634         (cl-return i))
1635       (cl-incf i))))
1636
1637 (defun company-search-keypad ()
1638   (interactive)
1639   (let* ((name (symbol-name last-command-event))
1640          (last-command-event (aref name (1- (length name)))))
1641     (company-search-printing-char)))
1642
1643 (defun company-search-printing-char ()
1644   (interactive)
1645   (company--search-assert-enabled)
1646   (let ((ss (concat company-search-string (string last-command-event))))
1647     (when company-search-filtering
1648       (company--search-update-predicate ss))
1649     (company--search-update-string ss)))
1650
1651 (defun company--search-update-predicate (&optional ss)
1652   (let* ((company-candidates-predicate
1653           (and (not (string= ss ""))
1654                company-search-filtering
1655                (lambda (candidate) (string-match ss candidate))))
1656          (cc (company-calculate-candidates company-prefix)))
1657     (unless cc (error "No match"))
1658     (company-update-candidates cc)))
1659
1660 (defun company--search-update-string (new)
1661   (let* ((pos (company--search new (nthcdr company-selection company-candidates))))
1662     (if (null pos)
1663         (ding)
1664       (setq company-search-string new)
1665       (company-set-selection (+ company-selection pos) t))))
1666
1667 (defun company--search-assert-input ()
1668   (company--search-assert-enabled)
1669   (when (string= company-search-string "")
1670     (error "Empty search string")))
1671
1672 (defun company-search-repeat-forward ()
1673   "Repeat the incremental search in completion candidates forward."
1674   (interactive)
1675   (company--search-assert-input)
1676   (let ((pos (company--search company-search-string
1677                               (cdr (nthcdr company-selection
1678                                            company-candidates)))))
1679     (if (null pos)
1680         (ding)
1681       (company-set-selection (+ company-selection pos 1) t))))
1682
1683 (defun company-search-repeat-backward ()
1684   "Repeat the incremental search in completion candidates backwards."
1685   (interactive)
1686   (company--search-assert-input)
1687   (let ((pos (company--search company-search-string
1688                               (nthcdr (- company-candidates-length
1689                                          company-selection)
1690                                       (reverse company-candidates)))))
1691     (if (null pos)
1692         (ding)
1693       (company-set-selection (- company-selection pos 1) t))))
1694
1695 (defun company-search-toggle-filtering ()
1696   "Toggle `company-search-filtering'."
1697   (interactive)
1698   (company--search-assert-enabled)
1699   (setq company-search-filtering (not company-search-filtering))
1700   (let ((ss company-search-string))
1701     (company--search-update-predicate ss)
1702     (company--search-update-string ss)))
1703
1704 (defun company-search-abort ()
1705   "Abort searching the completion candidates."
1706   (interactive)
1707   (company--search-assert-enabled)
1708   (company-search-mode 0)
1709   (company-set-selection company--search-old-selection t)
1710   (setq company-selection-changed company--search-old-changed))
1711
1712 (defun company-search-other-char ()
1713   (interactive)
1714   (company--search-assert-enabled)
1715   (company-search-mode 0)
1716   (company--unread-last-input))
1717
1718 (defun company-search-delete-char ()
1719   (interactive)
1720   (company--search-assert-enabled)
1721   (if (string= company-search-string "")
1722       (ding)
1723     (let ((ss (substring company-search-string 0 -1)))
1724       (when company-search-filtering
1725         (company--search-update-predicate ss))
1726       (company--search-update-string ss))))
1727
1728 (defvar company-search-map
1729   (let ((i 0)
1730         (keymap (make-keymap)))
1731     (if (fboundp 'max-char)
1732         (set-char-table-range (nth 1 keymap) (cons #x100 (max-char))
1733                               'company-search-printing-char)
1734       (with-no-warnings
1735         ;; obsolete in Emacs 23
1736         (let ((l (generic-character-list))
1737               (table (nth 1 keymap)))
1738           (while l
1739             (set-char-table-default table (car l) 'company-search-printing-char)
1740             (setq l (cdr l))))))
1741     (define-key keymap [t] 'company-search-other-char)
1742     (while (< i ?\s)
1743       (define-key keymap (make-string 1 i) 'company-search-other-char)
1744       (cl-incf i))
1745     (while (< i 256)
1746       (define-key keymap (vector i) 'company-search-printing-char)
1747       (cl-incf i))
1748     (dotimes (i 10)
1749       (define-key keymap (read (format "[kp-%s]" i)) 'company-search-keypad))
1750     (let ((meta-map (make-sparse-keymap)))
1751       (define-key keymap (char-to-string meta-prefix-char) meta-map)
1752       (define-key keymap [escape] meta-map))
1753     (define-key keymap (vector meta-prefix-char t) 'company-search-other-char)
1754     (define-key keymap (kbd "M-n") 'company-select-next)
1755     (define-key keymap (kbd "M-p") 'company-select-previous)
1756     (define-key keymap (kbd "<down>") 'company-select-next-or-abort)
1757     (define-key keymap (kbd "<up>") 'company-select-previous-or-abort)
1758     (define-key keymap "\e\e\e" 'company-search-other-char)
1759     (define-key keymap [escape escape escape] 'company-search-other-char)
1760     (define-key keymap (kbd "DEL") 'company-search-delete-char)
1761     (define-key keymap [backspace] 'company-search-delete-char)
1762     (define-key keymap "\C-g" 'company-search-abort)
1763     (define-key keymap "\C-s" 'company-search-repeat-forward)
1764     (define-key keymap "\C-r" 'company-search-repeat-backward)
1765     (define-key keymap "\C-o" 'company-search-toggle-filtering)
1766     (dotimes (i 10)
1767       (define-key keymap (read-kbd-macro (format "M-%d" i)) 'company-complete-number))
1768     keymap)
1769   "Keymap used for incrementally searching the completion candidates.")
1770
1771 (define-minor-mode company-search-mode
1772   "Search mode for completion candidates.
1773 Don't start this directly, use `company-search-candidates' or
1774 `company-filter-candidates'."
1775   nil company-search-lighter nil
1776   (if company-search-mode
1777       (if (company-manual-begin)
1778           (progn
1779             (setq company--search-old-selection company-selection
1780                   company--search-old-changed company-selection-changed)
1781             (company-call-frontends 'update)
1782             (company-enable-overriding-keymap company-search-map))
1783         (setq company-search-mode nil))
1784     (kill-local-variable 'company-search-string)
1785     (kill-local-variable 'company-search-filtering)
1786     (kill-local-variable 'company--search-old-selection)
1787     (kill-local-variable 'company--search-old-changed)
1788     (when company-backend
1789       (company--search-update-predicate "")
1790       (company-call-frontends 'update))
1791     (company-enable-overriding-keymap company-active-map)))
1792
1793 (defun company--search-assert-enabled ()
1794   (company-assert-enabled)
1795   (unless company-search-mode
1796     (company-uninstall-map)
1797     (error "Company not in search mode")))
1798
1799 (defun company-search-candidates ()
1800   "Start searching the completion candidates incrementally.
1801
1802 \\<company-search-map>Search can be controlled with the commands:
1803 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
1804 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
1805 - `company-search-abort' (\\[company-search-abort])
1806 - `company-search-delete-char' (\\[company-search-delete-char])
1807
1808 Regular characters are appended to the search string.
1809
1810 The command `company-search-toggle-filtering' (\\[company-search-toggle-filtering])
1811 uses the search string to filter the completion candidates."
1812   (interactive)
1813   (company-search-mode 1))
1814
1815 (defvar company-filter-map
1816   (let ((keymap (make-keymap)))
1817     (define-key keymap [remap company-search-printing-char]
1818       'company-filter-printing-char)
1819     (set-keymap-parent keymap company-search-map)
1820     keymap)
1821   "Keymap used for incrementally searching the completion candidates.")
1822
1823 (defun company-filter-candidates ()
1824   "Start filtering the completion candidates incrementally.
1825 This works the same way as `company-search-candidates' immediately
1826 followed by `company-search-toggle-filtering'."
1827   (interactive)
1828   (company-search-mode 1)
1829   (setq company-search-filtering t))
1830
1831 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1832
1833 (defun company-select-next (&optional arg)
1834   "Select the next candidate in the list.
1835
1836 With ARG, move by that many elements."
1837   (interactive "p")
1838   (when (company-manual-begin)
1839     (company-set-selection (+ (or arg 1) company-selection))))
1840
1841 (defun company-select-previous (&optional arg)
1842   "Select the previous candidate in the list.
1843
1844 With ARG, move by that many elements."
1845   (interactive "p")
1846   (company-select-next (if arg (- arg) -1)))
1847
1848 (defun company-select-next-or-abort (&optional arg)
1849   "Select the next candidate if more than one, else abort
1850 and invoke the normal binding.
1851
1852 With ARG, move by that many elements."
1853   (interactive "p")
1854   (if (> company-candidates-length 1)
1855       (company-select-next arg)
1856     (company-abort)
1857     (company--unread-last-input)))
1858
1859 (defun company-select-previous-or-abort (&optional arg)
1860   "Select the previous candidate if more than one, else abort
1861 and invoke the normal binding.
1862
1863 With ARG, move by that many elements."
1864   (interactive "p")
1865   (if (> company-candidates-length 1)
1866       (company-select-previous arg)
1867     (company-abort)
1868     (company--unread-last-input)))
1869
1870 (defun company-next-page ()
1871   "Select the candidate one page further."
1872   (interactive)
1873   (when (company-manual-begin)
1874     (company-set-selection (+ company-selection
1875                               company-tooltip-limit))))
1876
1877 (defun company-previous-page ()
1878   "Select the candidate one page earlier."
1879   (interactive)
1880   (when (company-manual-begin)
1881     (company-set-selection (- company-selection
1882                               company-tooltip-limit))))
1883
1884 (defvar company-pseudo-tooltip-overlay)
1885
1886 (defvar company-tooltip-offset)
1887
1888 (defun company--inside-tooltip-p (event-col-row row height)
1889   (let* ((ovl company-pseudo-tooltip-overlay)
1890          (column (overlay-get ovl 'company-column))
1891          (width (overlay-get ovl 'company-width))
1892          (evt-col (car event-col-row))
1893          (evt-row (cdr event-col-row)))
1894     (and (>= evt-col column)
1895          (< evt-col (+ column width))
1896          (if (> height 0)
1897              (and (> evt-row row)
1898                   (<= evt-row (+ row height) ))
1899            (and (< evt-row row)
1900                 (>= evt-row (+ row height)))))))
1901
1902 (defun company--event-col-row (event)
1903   (company--posn-col-row (event-start event)))
1904
1905 (defun company-select-mouse (event)
1906   "Select the candidate picked by the mouse."
1907   (interactive "e")
1908   (let ((event-col-row (company--event-col-row event))
1909         (ovl-row (company--row))
1910         (ovl-height (and company-pseudo-tooltip-overlay
1911                          (min (overlay-get company-pseudo-tooltip-overlay
1912                                            'company-height)
1913                               company-candidates-length))))
1914     (if (and ovl-height
1915              (company--inside-tooltip-p event-col-row ovl-row ovl-height))
1916         (progn
1917           (company-set-selection (+ (cdr event-col-row)
1918                                     (1- company-tooltip-offset)
1919                                     (if (and (eq company-tooltip-offset-display 'lines)
1920                                              (not (zerop company-tooltip-offset)))
1921                                         -1 0)
1922                                     (- ovl-row)
1923                                     (if (< ovl-height 0)
1924                                         (- 1 ovl-height)
1925                                       0)))
1926           t)
1927       (company-abort)
1928       (company--unread-last-input)
1929       nil)))
1930
1931 (defun company-complete-mouse (event)
1932   "Insert the candidate picked by the mouse."
1933   (interactive "e")
1934   (when (company-select-mouse event)
1935     (company-complete-selection)))
1936
1937 (defun company-complete-selection ()
1938   "Insert the selected candidate."
1939   (interactive)
1940   (when (company-manual-begin)
1941     (let ((result (nth company-selection company-candidates)))
1942       (company-finish result))))
1943
1944 (defun company-complete-common ()
1945   "Insert the common part of all candidates."
1946   (interactive)
1947   (when (company-manual-begin)
1948     (if (and (not (cdr company-candidates))
1949              (equal company-common (car company-candidates)))
1950         (company-complete-selection)
1951       (company--insert-candidate company-common))))
1952
1953 (defun company-complete-common-or-cycle (&optional arg)
1954   "Insert the common part of all candidates, or select the next one.
1955
1956 With ARG, move by that many elements."
1957   (interactive "p")
1958   (when (company-manual-begin)
1959     (let ((tick (buffer-chars-modified-tick)))
1960       (call-interactively 'company-complete-common)
1961       (when (eq tick (buffer-chars-modified-tick))
1962         (let ((company-selection-wrap-around t)
1963               (current-prefix-arg arg))
1964           (call-interactively 'company-select-next))))))
1965
1966 (defun company-indent-or-complete-common ()
1967   "Indent the current line or region, or complete the common part."
1968   (interactive)
1969   (cond
1970    ((use-region-p)
1971     (indent-region (region-beginning) (region-end)))
1972    ((let ((old-point (point))
1973           (old-tick (buffer-chars-modified-tick))
1974           (tab-always-indent t))
1975       (call-interactively #'indent-for-tab-command)
1976       (when (and (eq old-point (point))
1977                  (eq old-tick (buffer-chars-modified-tick)))
1978         (company-complete-common))))))
1979
1980 (defun company-complete ()
1981   "Insert the common part of all candidates or the current selection.
1982 The first time this is called, the common part is inserted, the second
1983 time, or when the selection has been changed, the selected candidate is
1984 inserted."
1985   (interactive)
1986   (when (company-manual-begin)
1987     (if (or company-selection-changed
1988             (eq last-command 'company-complete-common))
1989         (call-interactively 'company-complete-selection)
1990       (call-interactively 'company-complete-common)
1991       (setq this-command 'company-complete-common))))
1992
1993 (defun company-complete-number (n)
1994   "Insert the Nth candidate visible in the tooltip.
1995 To show the number next to the candidates in some backends, enable
1996 `company-show-numbers'.  When called interactively, uses the last typed
1997 character, stripping the modifiers.  That character must be a digit."
1998   (interactive
1999    (list (let* ((type (event-basic-type last-command-event))
2000                 (char (if (characterp type)
2001                           ;; Number on the main row.
2002                           type
2003                         ;; Keypad number, if bound directly.
2004                         (car (last (string-to-list (symbol-name type))))))
2005                 (n (- char ?0)))
2006            (if (zerop n) 10 n))))
2007   (when (company-manual-begin)
2008     (and (or (< n 1) (> n (- company-candidates-length
2009                              company-tooltip-offset)))
2010          (error "No candidate number %d" n))
2011     (cl-decf n)
2012     (company-finish (nth (+ n company-tooltip-offset)
2013                          company-candidates))))
2014
2015 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2016
2017 (defconst company-space-strings-limit 100)
2018
2019 (defconst company-space-strings
2020   (let (lst)
2021     (dotimes (i company-space-strings-limit)
2022       (push (make-string (- company-space-strings-limit 1 i) ?\  ) lst))
2023     (apply 'vector lst)))
2024
2025 (defun company-space-string (len)
2026   (if (< len company-space-strings-limit)
2027       (aref company-space-strings len)
2028     (make-string len ?\ )))
2029
2030 (defun company-safe-substring (str from &optional to)
2031   (if (> from (string-width str))
2032       ""
2033     (with-temp-buffer
2034       (insert str)
2035       (move-to-column from)
2036       (let ((beg (point)))
2037         (if to
2038             (progn
2039               (move-to-column to)
2040               (concat (buffer-substring beg (point))
2041                       (let ((padding (- to (current-column))))
2042                         (when (> padding 0)
2043                           (company-space-string padding)))))
2044           (buffer-substring beg (point-max)))))))
2045
2046 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2047
2048 (defvar-local company-last-metadata nil)
2049
2050 (defun company-fetch-metadata ()
2051   (let ((selected (nth company-selection company-candidates)))
2052     (unless (eq selected (car company-last-metadata))
2053       (setq company-last-metadata
2054             (cons selected (company-call-backend 'meta selected))))
2055     (cdr company-last-metadata)))
2056
2057 (defun company-doc-buffer (&optional string)
2058   (with-current-buffer (get-buffer-create "*company-documentation*")
2059     (erase-buffer)
2060     (when string
2061       (save-excursion
2062         (insert string)))
2063     (current-buffer)))
2064
2065 (defvar company--electric-commands
2066   '(scroll-other-window scroll-other-window-down mwheel-scroll)
2067   "List of Commands that won't break out of electric commands.")
2068
2069 (defmacro company--electric-do (&rest body)
2070   (declare (indent 0) (debug t))
2071   `(when (company-manual-begin)
2072      (save-window-excursion
2073        (let ((height (window-height))
2074              (row (company--row))
2075              cmd)
2076          ,@body
2077          (and (< (window-height) height)
2078               (< (- (window-height) row 2) company-tooltip-limit)
2079               (recenter (- (window-height) row 2)))
2080          (while (memq (setq cmd (key-binding (read-key-sequence-vector nil)))
2081                       company--electric-commands)
2082            (condition-case err
2083                (call-interactively cmd)
2084              ((beginning-of-buffer end-of-buffer)
2085               (message (error-message-string err)))))
2086          (company--unread-last-input)))))
2087
2088 (defun company--unread-last-input ()
2089   (when last-input-event
2090     (clear-this-command-keys t)
2091     (setq unread-command-events (list last-input-event))))
2092
2093 (defun company-show-doc-buffer ()
2094   "Temporarily show the documentation buffer for the selection."
2095   (interactive)
2096   (let (other-window-scroll-buffer)
2097     (company--electric-do
2098       (let* ((selected (nth company-selection company-candidates))
2099              (doc-buffer (or (company-call-backend 'doc-buffer selected)
2100                              (error "No documentation available")))
2101              start)
2102         (when (consp doc-buffer)
2103           (setq start (cdr doc-buffer)
2104                 doc-buffer (car doc-buffer)))
2105         (setq other-window-scroll-buffer (get-buffer doc-buffer))
2106         (let ((win (display-buffer doc-buffer t)))
2107           (set-window-start win (if start start (point-min))))))))
2108 (put 'company-show-doc-buffer 'company-keep t)
2109
2110 (defun company-show-location ()
2111   "Temporarily display a buffer showing the selected candidate in context."
2112   (interactive)
2113   (let (other-window-scroll-buffer)
2114     (company--electric-do
2115       (let* ((selected (nth company-selection company-candidates))
2116              (location (company-call-backend 'location selected))
2117              (pos (or (cdr location) (error "No location available")))
2118              (buffer (or (and (bufferp (car location)) (car location))
2119                          (find-file-noselect (car location) t))))
2120         (setq other-window-scroll-buffer (get-buffer buffer))
2121         (with-selected-window (display-buffer buffer t)
2122           (save-restriction
2123             (widen)
2124             (if (bufferp (car location))
2125                 (goto-char pos)
2126               (goto-char (point-min))
2127               (forward-line (1- pos))))
2128           (set-window-start nil (point)))))))
2129 (put 'company-show-location 'company-keep t)
2130
2131 ;;; package functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2132
2133 (defvar-local company-callback nil)
2134
2135 (defun company-remove-callback (&optional ignored)
2136   (remove-hook 'company-completion-finished-hook company-callback t)
2137   (remove-hook 'company-completion-cancelled-hook 'company-remove-callback t)
2138   (remove-hook 'company-completion-finished-hook 'company-remove-callback t))
2139
2140 (defun company-begin-backend (backend &optional callback)
2141   "Start a completion at point using BACKEND."
2142   (interactive (let ((val (completing-read "Company backend: "
2143                                            obarray
2144                                            'functionp nil "company-")))
2145                  (when val
2146                    (list (intern val)))))
2147   (when (setq company-callback callback)
2148     (add-hook 'company-completion-finished-hook company-callback nil t))
2149   (add-hook 'company-completion-cancelled-hook 'company-remove-callback nil t)
2150   (add-hook 'company-completion-finished-hook 'company-remove-callback nil t)
2151   (setq company-backend backend)
2152   ;; Return non-nil if active.
2153   (or (company-manual-begin)
2154       (error "Cannot complete at point")))
2155
2156 (defun company-begin-with (candidates
2157                            &optional prefix-length require-match callback)
2158   "Start a completion at point.
2159 CANDIDATES is the list of candidates to use and PREFIX-LENGTH is the length
2160 of the prefix that already is in the buffer before point.
2161 It defaults to 0.
2162
2163 CALLBACK is a function called with the selected result if the user
2164 successfully completes the input.
2165
2166 Example: \(company-begin-with '\(\"foo\" \"foobar\" \"foobarbaz\"\)\)"
2167   (let ((begin-marker (copy-marker (point) t)))
2168     (company-begin-backend
2169      (lambda (command &optional arg &rest ignored)
2170        (pcase command
2171          (`prefix
2172           (when (equal (point) (marker-position begin-marker))
2173             (buffer-substring (- (point) (or prefix-length 0)) (point))))
2174          (`candidates
2175           (all-completions arg candidates))
2176          (`require-match
2177           require-match)))
2178      callback)))
2179
2180 (defun company-version (&optional show-version)
2181   "Get the Company version as string.
2182
2183 If SHOW-VERSION is non-nil, show the version in the echo area."
2184   (interactive (list t))
2185   (with-temp-buffer
2186     (require 'find-func)
2187     (insert-file-contents (find-library-name "company"))
2188     (require 'lisp-mnt)
2189     (if show-version
2190         (message "Company version: %s" (lm-version))
2191       (lm-version))))
2192
2193 (defun company-diag ()
2194   "Pop a buffer with information about completions at point."
2195   (interactive)
2196   (let* ((bb company-backends)
2197          backend
2198          (prefix (cl-loop for b in bb
2199                           thereis (let ((company-backend b))
2200                                     (setq backend b)
2201                                     (company-call-backend 'prefix))))
2202          cc annotations)
2203     (when (stringp prefix)
2204       (let ((company-backend backend))
2205         (setq cc (company-call-backend 'candidates prefix)
2206               annotations
2207               (mapcar
2208                (lambda (c) (cons c (company-call-backend 'annotation c)))
2209                cc))))
2210     (pop-to-buffer (get-buffer-create "*company-diag*"))
2211     (setq buffer-read-only nil)
2212     (erase-buffer)
2213     (insert (format "Emacs %s (%s) of %s on %s"
2214                     emacs-version system-configuration
2215                     (format-time-string "%Y-%m-%d" emacs-build-time)
2216                     emacs-build-system))
2217     (insert "\nCompany " (company-version) "\n\n")
2218     (insert "company-backends: " (pp-to-string bb))
2219     (insert "\n")
2220     (insert "Used backend: " (pp-to-string backend))
2221     (insert "\n")
2222     (insert "Prefix: " (pp-to-string prefix))
2223     (insert "\n")
2224     (insert (message  "Completions:"))
2225     (unless cc (insert " none"))
2226     (save-excursion
2227       (dolist (c annotations)
2228         (insert "\n  " (prin1-to-string (car c)))
2229         (when (cdr c)
2230           (insert " " (prin1-to-string (cdr c))))))
2231     (special-mode)))
2232
2233 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2234
2235 (defvar-local company-pseudo-tooltip-overlay nil)
2236
2237 (defvar-local company-tooltip-offset 0)
2238
2239 (defun company-tooltip--lines-update-offset (selection num-lines limit)
2240   (cl-decf limit 2)
2241   (setq company-tooltip-offset
2242         (max (min selection company-tooltip-offset)
2243              (- selection -1 limit)))
2244
2245   (when (<= company-tooltip-offset 1)
2246     (cl-incf limit)
2247     (setq company-tooltip-offset 0))
2248
2249   (when (>= company-tooltip-offset (- num-lines limit 1))
2250     (cl-incf limit)
2251     (when (= selection (1- num-lines))
2252       (cl-decf company-tooltip-offset)
2253       (when (<= company-tooltip-offset 1)
2254         (setq company-tooltip-offset 0)
2255         (cl-incf limit))))
2256
2257   limit)
2258
2259 (defun company-tooltip--simple-update-offset (selection _num-lines limit)
2260   (setq company-tooltip-offset
2261         (if (< selection company-tooltip-offset)
2262             selection
2263           (max company-tooltip-offset
2264                (- selection limit -1)))))
2265
2266 ;;; propertize
2267
2268 (defsubst company-round-tab (arg)
2269   (* (/ (+ arg tab-width) tab-width) tab-width))
2270
2271 (defun company-plainify (str)
2272   (let ((prefix (get-text-property 0 'line-prefix str)))
2273     (when prefix ; Keep the original value unmodified, for no special reason.
2274       (setq str (concat prefix str))
2275       (remove-text-properties 0 (length str) '(line-prefix) str)))
2276   (let* ((pieces (split-string str "\t"))
2277          (copy pieces))
2278     (while (cdr copy)
2279       (setcar copy (company-safe-substring
2280                     (car copy) 0 (company-round-tab (string-width (car copy)))))
2281       (pop copy))
2282     (apply 'concat pieces)))
2283
2284 (defun company-fill-propertize (value annotation width selected left right)
2285   (let* ((margin (length left))
2286          (common (or (company-call-backend 'match value)
2287                      (if company-common
2288                          (string-width company-common)
2289                        0)))
2290          (ann-ralign company-tooltip-align-annotations)
2291          (ann-truncate (< width
2292                           (+ (length value) (length annotation)
2293                              (if ann-ralign 1 0))))
2294          (ann-start (+ margin
2295                        (if ann-ralign
2296                            (if ann-truncate
2297                                (1+ (length value))
2298                              (- width (length annotation)))
2299                          (length value))))
2300          (ann-end (min (+ ann-start (length annotation)) (+ margin width)))
2301          (line (concat left
2302                        (if (or ann-truncate (not ann-ralign))
2303                            (company-safe-substring
2304                             (concat value
2305                                     (when (and annotation ann-ralign) " ")
2306                                     annotation)
2307                             0 width)
2308                          (concat
2309                           (company-safe-substring value 0
2310                                                   (- width (length annotation)))
2311                           annotation))
2312                        right)))
2313     (setq common (+ (min common width) margin))
2314     (setq width (+ width margin (length right)))
2315
2316     (add-text-properties 0 width '(face company-tooltip
2317                                    mouse-face company-tooltip-mouse)
2318                          line)
2319     (add-text-properties margin common
2320                          '(face company-tooltip-common
2321                            mouse-face company-tooltip-mouse)
2322                          line)
2323     (when (< ann-start ann-end)
2324       (add-text-properties ann-start ann-end
2325                            '(face company-tooltip-annotation
2326                              mouse-face company-tooltip-mouse)
2327                            line))
2328     (when selected
2329       (if (and (not (string= company-search-string ""))
2330                (string-match (regexp-quote company-search-string) value
2331                              (length company-prefix)))
2332           (let ((beg (+ margin (match-beginning 0)))
2333                 (end (+ margin (match-end 0)))
2334                 (width (- width (length right))))
2335             (when (< beg width)
2336               (add-text-properties beg (min end width)
2337                                    '(face company-tooltip-search)
2338                                    line)))
2339         (add-text-properties 0 width '(face company-tooltip-selection
2340                                        mouse-face company-tooltip-selection)
2341                              line)
2342         (add-text-properties margin common
2343                              '(face company-tooltip-common-selection
2344                                mouse-face company-tooltip-selection)
2345                              line)))
2346     line))
2347
2348 (defun company--clean-string (str)
2349   (replace-regexp-in-string
2350    "\\([^[:graph:] ]\\)\\|\\(\ufeff\\)\\|[[:multibyte:]]"
2351    (lambda (match)
2352      (cond
2353       ((match-beginning 1)
2354        ;; FIXME: Better char for 'non-printable'?
2355        ;; We shouldn't get any of these, but sometimes we might.
2356        "\u2017")
2357       ((match-beginning 2)
2358        ;; Zero-width non-breakable space.
2359        "")
2360       ((> (string-width match) 1)
2361        (concat
2362         (make-string (1- (string-width match)) ?\ufeff)
2363         match))
2364       (t match)))
2365    str))
2366
2367 ;;; replace
2368
2369 (defun company-buffer-lines (beg end)
2370   (goto-char beg)
2371   (let (lines lines-moved)
2372     (while (and (not (eobp)) ; http://debbugs.gnu.org/19553
2373                 (> (setq lines-moved (vertical-motion 1)) 0)
2374                 (<= (point) end))
2375       (let ((bound (min end (point))))
2376         ;; A visual line can contain several physical lines (e.g. with outline's
2377         ;; folding overlay).  Take only the first one.
2378         (push (buffer-substring beg
2379                                 (save-excursion
2380                                   (goto-char beg)
2381                                   (re-search-forward "$" bound 'move)
2382                                   (point)))
2383               lines))
2384       ;; One physical line can be displayed as several visual ones as well:
2385       ;; add empty strings to the list, to even the count.
2386       (dotimes (_ (1- lines-moved))
2387         (push "" lines))
2388       (setq beg (point)))
2389     (unless (eq beg end)
2390       (push (buffer-substring beg end) lines))
2391     (nreverse lines)))
2392
2393 (defun company-modify-line (old new offset)
2394   (concat (company-safe-substring old 0 offset)
2395           new
2396           (company-safe-substring old (+ offset (length new)))))
2397
2398 (defsubst company--length-limit (lst limit)
2399   (if (nthcdr limit lst)
2400       limit
2401     (length lst)))
2402
2403 (defsubst company--window-height ()
2404   (if (fboundp 'window-screen-lines)
2405       (floor (window-screen-lines))
2406     (window-body-height)))
2407
2408 (defun company--window-width ()
2409   (let ((ww (window-body-width)))
2410     ;; Account for the line continuation column.
2411     (when (zerop (cadr (window-fringes)))
2412       (cl-decf ww))
2413     (unless (or (display-graphic-p)
2414                 (version< "24.3.1" emacs-version))
2415       ;; Emacs 24.3 and earlier included margins
2416       ;; in window-width when in TTY.
2417       (cl-decf ww
2418                (let ((margins (window-margins)))
2419                  (+ (or (car margins) 0)
2420                     (or (cdr margins) 0)))))
2421     (when (and word-wrap
2422                (version< emacs-version "24.4.51.5"))
2423       ;; http://debbugs.gnu.org/19300
2424       (cl-decf ww))
2425     ;; whitespace-mode with newline-mark
2426     (when (and buffer-display-table
2427                (aref buffer-display-table ?\n))
2428       (cl-decf ww (1- (length (aref buffer-display-table ?\n)))))
2429     ww))
2430
2431 (defun company--replacement-string (lines old column nl &optional align-top)
2432   (cl-decf column company-tooltip-margin)
2433
2434   (when (and align-top company-tooltip-flip-when-above)
2435     (setq lines (reverse lines)))
2436
2437   (let ((width (length (car lines)))
2438         (remaining-cols (- (+ (company--window-width) (window-hscroll))
2439                            column)))
2440     (when (> width remaining-cols)
2441       (cl-decf column (- width remaining-cols))))
2442
2443   (let ((offset (and (< column 0) (- column)))
2444         new)
2445     (when offset
2446       (setq column 0))
2447     (when align-top
2448       ;; untouched lines first
2449       (dotimes (_ (- (length old) (length lines)))
2450         (push (pop old) new)))
2451     ;; length into old lines.
2452     (while old
2453       (push (company-modify-line (pop old)
2454                                  (company--offset-line (pop lines) offset)
2455                                  column)
2456             new))
2457     ;; Append whole new lines.
2458     (while lines
2459       (push (concat (company-space-string column)
2460                     (company--offset-line (pop lines) offset))
2461             new))
2462
2463     (let ((str (concat (when nl " \n")
2464                        (mapconcat 'identity (nreverse new) "\n")
2465                        "\n")))
2466       (font-lock-append-text-property 0 (length str) 'face 'default str)
2467       (when nl (put-text-property 0 1 'cursor t str))
2468       str)))
2469
2470 (defun company--offset-line (line offset)
2471   (if (and offset line)
2472       (substring line offset)
2473     line))
2474
2475 (defun company--create-lines (selection limit)
2476   (let ((len company-candidates-length)
2477         (window-width (company--window-width))
2478         lines
2479         width
2480         lines-copy
2481         items
2482         previous
2483         remainder
2484         scrollbar-bounds)
2485
2486     ;; Maybe clear old offset.
2487     (when (< len (+ company-tooltip-offset limit))
2488       (setq company-tooltip-offset 0))
2489
2490     ;; Scroll to offset.
2491     (if (eq company-tooltip-offset-display 'lines)
2492         (setq limit (company-tooltip--lines-update-offset selection len limit))
2493       (company-tooltip--simple-update-offset selection len limit))
2494
2495     (cond
2496      ((eq company-tooltip-offset-display 'scrollbar)
2497       (setq scrollbar-bounds (company--scrollbar-bounds company-tooltip-offset
2498                                                         limit len)))
2499      ((eq company-tooltip-offset-display 'lines)
2500       (when (> company-tooltip-offset 0)
2501         (setq previous (format "...(%d)" company-tooltip-offset)))
2502       (setq remainder (- len limit company-tooltip-offset)
2503             remainder (when (> remainder 0)
2504                         (setq remainder (format "...(%d)" remainder))))))
2505
2506     (cl-decf selection company-tooltip-offset)
2507     (setq width (max (length previous) (length remainder))
2508           lines (nthcdr company-tooltip-offset company-candidates)
2509           len (min limit len)
2510           lines-copy lines)
2511
2512     (cl-decf window-width (* 2 company-tooltip-margin))
2513     (when scrollbar-bounds (cl-decf window-width))
2514
2515     (dotimes (_ len)
2516       (let* ((value (pop lines-copy))
2517              (annotation (company-call-backend 'annotation value)))
2518         (setq value (company--clean-string (company-reformat value)))
2519         (when annotation
2520           (when company-tooltip-align-annotations
2521             ;; `lisp-completion-at-point' adds a space.
2522             (setq annotation (comment-string-strip annotation t nil)))
2523           (setq annotation (company--clean-string annotation)))
2524         (push (cons value annotation) items)
2525         (setq width (max (+ (length value)
2526                             (if (and annotation company-tooltip-align-annotations)
2527                                 (1+ (length annotation))
2528                               (length annotation)))
2529                          width))))
2530
2531     (setq width (min window-width
2532                      (max company-tooltip-minimum-width
2533                           (if company-show-numbers
2534                               (+ 2 width)
2535                             width))))
2536
2537     (let ((items (nreverse items))
2538           (numbered (if company-show-numbers 0 99999))
2539           new)
2540       (when previous
2541         (push (company--scrollpos-line previous width) new))
2542
2543       (dotimes (i len)
2544         (let* ((item (pop items))
2545                (str (car item))
2546                (annotation (cdr item))
2547                (right (company-space-string company-tooltip-margin))
2548                (width width))
2549           (when (< numbered 10)
2550             (cl-decf width 2)
2551             (cl-incf numbered)
2552             (setq right (concat (format " %d" (mod numbered 10)) right)))
2553           (push (concat
2554                  (company-fill-propertize str annotation
2555                                           width (equal i selection)
2556                                           (company-space-string
2557                                            company-tooltip-margin)
2558                                           right)
2559                  (when scrollbar-bounds
2560                    (company--scrollbar i scrollbar-bounds)))
2561                 new)))
2562
2563       (when remainder
2564         (push (company--scrollpos-line remainder width) new))
2565
2566       (nreverse new))))
2567
2568 (defun company--scrollbar-bounds (offset limit length)
2569   (when (> length limit)
2570     (let* ((size (ceiling (* limit (float limit)) length))
2571            (lower (floor (* limit (float offset)) length))
2572            (upper (+ lower size -1)))
2573       (cons lower upper))))
2574
2575 (defun company--scrollbar (i bounds)
2576   (propertize " " 'face
2577               (if (and (>= i (car bounds)) (<= i (cdr bounds)))
2578                   'company-scrollbar-fg
2579                 'company-scrollbar-bg)))
2580
2581 (defun company--scrollpos-line (text width)
2582   (propertize (concat (company-space-string company-tooltip-margin)
2583                       (company-safe-substring text 0 width)
2584                       (company-space-string company-tooltip-margin))
2585               'face 'company-tooltip))
2586
2587 ;; show
2588
2589 (defun company--pseudo-tooltip-height ()
2590   "Calculate the appropriate tooltip height.
2591 Returns a negative number if the tooltip should be displayed above point."
2592   (let* ((lines (company--row))
2593          (below (- (company--window-height) 1 lines)))
2594     (if (and (< below (min company-tooltip-minimum company-candidates-length))
2595              (> lines below))
2596         (- (max 3 (min company-tooltip-limit lines)))
2597       (max 3 (min company-tooltip-limit below)))))
2598
2599 (defun company-pseudo-tooltip-show (row column selection)
2600   (company-pseudo-tooltip-hide)
2601   (save-excursion
2602
2603     (let* ((height (company--pseudo-tooltip-height))
2604            above)
2605
2606       (when (< height 0)
2607         (setq row (+ row height -1)
2608               above t))
2609
2610       (let* ((nl (< (move-to-window-line row) row))
2611              (beg (point))
2612              (end (save-excursion
2613                     (move-to-window-line (+ row (abs height)))
2614                     (point)))
2615              (ov (make-overlay beg end nil t))
2616              (args (list (mapcar 'company-plainify
2617                                  (company-buffer-lines beg end))
2618                          column nl above)))
2619
2620         (setq company-pseudo-tooltip-overlay ov)
2621         (overlay-put ov 'company-replacement-args args)
2622
2623         (let ((lines (company--create-lines selection (abs height))))
2624           (overlay-put ov 'company-display
2625                        (apply 'company--replacement-string lines args))
2626           (overlay-put ov 'company-width (string-width (car lines))))
2627
2628         (overlay-put ov 'company-column column)
2629         (overlay-put ov 'company-height height)))))
2630
2631 (defun company-pseudo-tooltip-show-at-point (pos column-offset)
2632   (let* ((col-row (company--col-row pos))
2633          (col (- (car col-row) column-offset)))
2634     (when (< col 0) (setq col 0))
2635     (company-pseudo-tooltip-show (1+ (cdr col-row)) col company-selection)))
2636
2637 (defun company-pseudo-tooltip-edit (selection)
2638   (let* ((height (overlay-get company-pseudo-tooltip-overlay 'company-height))
2639          (lines  (company--create-lines selection (abs height))))
2640     (overlay-put company-pseudo-tooltip-overlay 'company-width
2641                  (string-width (car lines)))
2642     (overlay-put company-pseudo-tooltip-overlay 'company-display
2643                  (apply 'company--replacement-string
2644                         lines
2645                         (overlay-get company-pseudo-tooltip-overlay
2646                                      'company-replacement-args)))))
2647
2648 (defun company-pseudo-tooltip-hide ()
2649   (when company-pseudo-tooltip-overlay
2650     (delete-overlay company-pseudo-tooltip-overlay)
2651     (setq company-pseudo-tooltip-overlay nil)))
2652
2653 (defun company-pseudo-tooltip-hide-temporarily ()
2654   (when (overlayp company-pseudo-tooltip-overlay)
2655     (overlay-put company-pseudo-tooltip-overlay 'invisible nil)
2656     (overlay-put company-pseudo-tooltip-overlay 'line-prefix nil)
2657     (overlay-put company-pseudo-tooltip-overlay 'after-string nil)
2658     (overlay-put company-pseudo-tooltip-overlay 'display nil)))
2659
2660 (defun company-pseudo-tooltip-unhide ()
2661   (when company-pseudo-tooltip-overlay
2662     (let* ((ov company-pseudo-tooltip-overlay)
2663            (disp (overlay-get ov 'company-display)))
2664       ;; Beat outline's folding overlays, at least.
2665       (overlay-put ov 'priority 1)
2666       ;; No (extra) prefix for the first line.
2667       (overlay-put ov 'line-prefix "")
2668       ;; `display' is better
2669       ;; (http://debbugs.gnu.org/18285, http://debbugs.gnu.org/20847),
2670       ;; but it doesn't work on 0-length overlays.
2671       (if (< (overlay-start ov) (overlay-end ov))
2672           (overlay-put ov 'display disp)
2673         (overlay-put ov 'after-string disp)
2674         (overlay-put ov 'invisible t))
2675       (overlay-put ov 'window (selected-window)))))
2676
2677 (defun company-pseudo-tooltip-guard ()
2678   (cons
2679    (save-excursion (beginning-of-visual-line))
2680    (let ((ov company-pseudo-tooltip-overlay)
2681          (overhang (save-excursion (end-of-visual-line)
2682                                    (- (line-end-position) (point)))))
2683      (when (>= (overlay-get ov 'company-height) 0)
2684        (cons
2685         (buffer-substring-no-properties (point) (overlay-start ov))
2686         (when (>= overhang 0) overhang))))))
2687
2688 (defun company-pseudo-tooltip-frontend (command)
2689   "`company-mode' frontend similar to a tooltip but based on overlays."
2690   (cl-case command
2691     (pre-command (company-pseudo-tooltip-hide-temporarily))
2692     (post-command
2693      (unless (when (overlayp company-pseudo-tooltip-overlay)
2694               (let* ((ov company-pseudo-tooltip-overlay)
2695                      (old-height (overlay-get ov 'company-height))
2696                      (new-height (company--pseudo-tooltip-height)))
2697                 (and
2698                  (>= (* old-height new-height) 0)
2699                  (>= (abs old-height) (abs new-height))
2700                  (equal (company-pseudo-tooltip-guard)
2701                         (overlay-get ov 'company-guard)))))
2702        ;; Redraw needed.
2703        (company-pseudo-tooltip-show-at-point (point) (length company-prefix))
2704        (overlay-put company-pseudo-tooltip-overlay
2705                     'company-guard (company-pseudo-tooltip-guard)))
2706      (company-pseudo-tooltip-unhide))
2707     (hide (company-pseudo-tooltip-hide)
2708           (setq company-tooltip-offset 0))
2709     (update (when (overlayp company-pseudo-tooltip-overlay)
2710               (company-pseudo-tooltip-edit company-selection)))))
2711
2712 (defun company-pseudo-tooltip-unless-just-one-frontend (command)
2713   "`company-pseudo-tooltip-frontend', but not shown for single candidates."
2714   (unless (and (eq command 'post-command)
2715                (company--show-inline-p))
2716     (company-pseudo-tooltip-frontend command)))
2717
2718 ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2719
2720 (defvar-local company-preview-overlay nil)
2721
2722 (defun company-preview-show-at-point (pos)
2723   (company-preview-hide)
2724
2725   (let ((completion (nth company-selection company-candidates)))
2726     (setq completion (propertize completion 'face 'company-preview))
2727     (add-text-properties 0 (length company-common)
2728                          '(face company-preview-common) completion)
2729
2730     ;; Add search string
2731     (and company-search-string
2732          (string-match (regexp-quote company-search-string) completion)
2733          (add-text-properties (match-beginning 0)
2734                               (match-end 0)
2735                               '(face company-preview-search)
2736                               completion))
2737
2738     (setq completion (company-strip-prefix completion))
2739
2740     (and (equal pos (point))
2741          (not (equal completion ""))
2742          (add-text-properties 0 1 '(cursor 1) completion))
2743
2744     (let* ((beg pos)
2745            (pto company-pseudo-tooltip-overlay)
2746            (ptf-workaround (and
2747                             pto
2748                             (char-before pos)
2749                             (eq pos (overlay-start pto)))))
2750       ;; Try to accomodate for the pseudo-tooltip overlay,
2751       ;; which may start at the same position if it's at eol.
2752       (when ptf-workaround
2753         (cl-decf beg)
2754         (setq completion (concat (buffer-substring beg pos) completion)))
2755
2756       (setq company-preview-overlay (make-overlay beg pos))
2757
2758       (let ((ov company-preview-overlay))
2759         (overlay-put ov (if ptf-workaround 'display 'after-string)
2760                      completion)
2761         (overlay-put ov 'window (selected-window))))))
2762
2763 (defun company-preview-hide ()
2764   (when company-preview-overlay
2765     (delete-overlay company-preview-overlay)
2766     (setq company-preview-overlay nil)))
2767
2768 (defun company-preview-frontend (command)
2769   "`company-mode' frontend showing the selection as if it had been inserted."
2770   (pcase command
2771     (`pre-command (company-preview-hide))
2772     (`post-command (company-preview-show-at-point (point)))
2773     (`hide (company-preview-hide))))
2774
2775 (defun company-preview-if-just-one-frontend (command)
2776   "`company-preview-frontend', but only shown for single candidates."
2777   (when (or (not (eq command 'post-command))
2778             (company--show-inline-p))
2779     (company-preview-frontend command)))
2780
2781 (defun company--show-inline-p ()
2782   (and (not (cdr company-candidates))
2783        company-common
2784        (or (eq (company-call-backend 'ignore-case) 'keep-prefix)
2785            (string-prefix-p company-prefix company-common))))
2786
2787 ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2788
2789 (defvar-local company-echo-last-msg nil)
2790
2791 (defvar company-echo-timer nil)
2792
2793 (defvar company-echo-delay .01)
2794
2795 (defun company-echo-show (&optional getter)
2796   (when getter
2797     (setq company-echo-last-msg (funcall getter)))
2798   (let ((message-log-max nil))
2799     (if company-echo-last-msg
2800         (message "%s" company-echo-last-msg)
2801       (message ""))))
2802
2803 (defun company-echo-show-soon (&optional getter)
2804   (company-echo-cancel)
2805   (setq company-echo-timer (run-with-timer 0 nil 'company-echo-show getter)))
2806
2807 (defun company-echo-cancel (&optional unset)
2808   (when company-echo-timer
2809     (cancel-timer company-echo-timer))
2810   (when unset
2811     (setq company-echo-timer nil)))
2812
2813 (defun company-echo-show-when-idle (&optional getter)
2814   (company-echo-cancel)
2815   (setq company-echo-timer
2816         (run-with-idle-timer company-echo-delay nil 'company-echo-show getter)))
2817
2818 (defun company-echo-format ()
2819
2820   (let ((limit (window-body-width (minibuffer-window)))
2821         (len -1)
2822         ;; Roll to selection.
2823         (candidates (nthcdr company-selection company-candidates))
2824         (i (if company-show-numbers company-selection 99999))
2825         comp msg)
2826
2827     (while candidates
2828       (setq comp (company-reformat (pop candidates))
2829             len (+ len 1 (length comp)))
2830       (if (< i 10)
2831           ;; Add number.
2832           (progn
2833             (setq comp (propertize (format "%d: %s" i comp)
2834                                    'face 'company-echo))
2835             (cl-incf len 3)
2836             (cl-incf i)
2837             (add-text-properties 3 (+ 3 (length company-common))
2838                                  '(face company-echo-common) comp))
2839         (setq comp (propertize comp 'face 'company-echo))
2840         (add-text-properties 0 (length company-common)
2841                              '(face company-echo-common) comp))
2842       (if (>= len limit)
2843           (setq candidates nil)
2844         (push comp msg)))
2845
2846     (mapconcat 'identity (nreverse msg) " ")))
2847
2848 (defun company-echo-strip-common-format ()
2849
2850   (let ((limit (window-body-width (minibuffer-window)))
2851         (len (+ (length company-prefix) 2))
2852         ;; Roll to selection.
2853         (candidates (nthcdr company-selection company-candidates))
2854         (i (if company-show-numbers company-selection 99999))
2855         msg comp)
2856
2857     (while candidates
2858       (setq comp (company-strip-prefix (pop candidates))
2859             len (+ len 2 (length comp)))
2860       (when (< i 10)
2861         ;; Add number.
2862         (setq comp (format "%s (%d)" comp i))
2863         (cl-incf len 4)
2864         (cl-incf i))
2865       (if (>= len limit)
2866           (setq candidates nil)
2867         (push (propertize comp 'face 'company-echo) msg)))
2868
2869     (concat (propertize company-prefix 'face 'company-echo-common) "{"
2870             (mapconcat 'identity (nreverse msg) ", ")
2871             "}")))
2872
2873 (defun company-echo-hide ()
2874   (unless (equal company-echo-last-msg "")
2875     (setq company-echo-last-msg "")
2876     (company-echo-show)))
2877
2878 (defun company-echo-frontend (command)
2879   "`company-mode' frontend showing the candidates in the echo area."
2880   (pcase command
2881     (`post-command (company-echo-show-soon 'company-echo-format))
2882     (`hide (company-echo-hide))))
2883
2884 (defun company-echo-strip-common-frontend (command)
2885   "`company-mode' frontend showing the candidates in the echo area."
2886   (pcase command
2887     (`post-command (company-echo-show-soon 'company-echo-strip-common-format))
2888     (`hide (company-echo-hide))))
2889
2890 (defun company-echo-metadata-frontend (command)
2891   "`company-mode' frontend showing the documentation in the echo area."
2892   (pcase command
2893     (`post-command (company-echo-show-when-idle 'company-fetch-metadata))
2894     (`hide (company-echo-hide))))
2895
2896 (provide 'company)
2897 ;;; company.el ends here