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

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