dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

company.el (163599B)


      1 ;;; company.el --- Modular text completion framework  -*- lexical-binding: t -*-
      2 
      3 ;; Copyright (C) 2009-2023  Free Software Foundation, Inc.
      4 
      5 ;; Author: Nikolaj Schumacher
      6 ;; Maintainer: Dmitry Gutov <dmitry@gutov.dev>
      7 ;; URL: http://company-mode.github.io/
      8 ;; Version: 0.10.2
      9 ;; Keywords: abbrev, convenience, matching
     10 ;; Package-Requires: ((emacs "25.1"))
     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 <https://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 ;;   (interactive (list 'interactive))
     48 ;;   (pcase command
     49 ;;     (`interactive (company-begin-backend 'company-my-backend))
     50 ;;     (`prefix (company-grab-symbol))
     51 ;;     (`candidates (list "foobar" "foobaz" "foobarbaz"))
     52 ;;     (`meta (format "This value is named %s" arg))))
     53 ;;
     54 ;; Sometimes it is a good idea to mix several backends together, for example to
     55 ;; enrich gtags with dabbrev-code results (to emulate local variables).  To do
     56 ;; this, add a list with both backends as an element in `company-backends'.
     57 ;;
     58 ;;; Change Log:
     59 ;;
     60 ;; See NEWS.md in the repository.
     61 
     62 ;;; Code:
     63 
     64 (require 'cl-lib)
     65 (require 'subr-x)
     66 (require 'pcase)
     67 
     68 (defgroup company nil
     69   "Extensible inline text completion mechanism."
     70   :group 'abbrev
     71   :group 'convenience
     72   :group 'matching
     73   :link '(custom-manual "(company) Top"))
     74 
     75 (defgroup company-faces nil
     76   "Faces used by Company."
     77   :group 'company
     78   :group 'faces)
     79 
     80 (defface company-tooltip
     81   '((((class color) (min-colors 88) (background light))
     82      (:foreground "black" :background "cornsilk"))
     83     (((class color) (min-colors 88) (background dark))
     84      (:background "gray26"))
     85     (t (:foreground "black" :background "yellow")))
     86   "Face used for the tooltip.")
     87 
     88 (defface company-tooltip-selection
     89   '((((class color) (min-colors 88) (background light))
     90      (:background "light blue"))
     91     (((class color) (min-colors 88) (background dark))
     92      (:background "gray31"))
     93     (t (:background "green")))
     94   "Face used for the selection in the tooltip.")
     95 
     96 (defface company-tooltip-deprecated
     97   '((t (:strike-through t)))
     98   "Face used for the deprecated items.")
     99 
    100 (defface company-tooltip-search
    101   '((default :inherit highlight))
    102   "Face used for the search string in the tooltip.")
    103 
    104 (defface company-tooltip-search-selection
    105   '((default :inherit highlight))
    106   "Face used for the search string inside the selection in the tooltip.")
    107 
    108 (defface company-tooltip-mouse
    109   '((default :inherit highlight))
    110   "Face used for the tooltip item under the mouse.")
    111 
    112 (defface company-tooltip-common
    113   '((((background light))
    114      :foreground "darkred")
    115     (((background dark))
    116      :foreground "pale turquoise"))
    117   "Face used for the common completion in the tooltip.")
    118 
    119 (defface company-tooltip-common-selection
    120   '((default :inherit company-tooltip-common))
    121   "Face used for the selected common completion in the tooltip.")
    122 
    123 (defface company-tooltip-annotation
    124   '((((background light))
    125      :foreground "firebrick4")
    126     (((background dark))
    127      :foreground "LightCyan3"))
    128   "Face used for the completion annotation in the tooltip.")
    129 
    130 (defface company-tooltip-annotation-selection
    131   '((default :inherit company-tooltip-annotation))
    132   "Face used for the selected completion annotation in the tooltip.")
    133 
    134 (defface company-tooltip-quick-access
    135   '((default :inherit company-tooltip-annotation))
    136   "Face used for the quick-access hints shown in the tooltip."
    137   :package-version '(company . "0.10.0"))
    138 
    139 (defface company-tooltip-quick-access-selection
    140   '((default :inherit company-tooltip-annotation-selection))
    141   "Face used for the selected quick-access hints shown in the tooltip."
    142   :package-version '(company . "0.10.0"))
    143 
    144 (define-obsolete-face-alias
    145  'company-scrollbar-fg
    146  'company-tooltip-scrollbar-thumb
    147  "0.10.0")
    148 
    149 (defface company-tooltip-scrollbar-thumb
    150   '((((background light))
    151      :background "darkred")
    152     (((background dark))
    153      :background "gray33"))
    154   "Face used for the tooltip scrollbar thumb (bar).")
    155 
    156 (define-obsolete-face-alias
    157  'company-scrollbar-bg
    158  'company-tooltip-scrollbar-track
    159  "0.10.0")
    160 
    161 (defface company-tooltip-scrollbar-track
    162   '((((background light))
    163      :background "wheat")
    164     (((background dark))
    165      :background "gray28"))
    166   "Face used for the tooltip scrollbar track (trough).")
    167 
    168 (defface company-preview
    169   '((default :inherit (company-tooltip-selection company-tooltip)))
    170   "Face used for the completion preview.")
    171 
    172 (defface company-preview-common
    173   '((default :inherit company-tooltip-common-selection))
    174   "Face used for the common part of the completion preview.")
    175 
    176 (defface company-preview-search
    177   '((default :inherit company-tooltip-common-selection))
    178   "Face used for the search string in the completion preview.")
    179 
    180 (defface company-echo nil
    181   "Face used for completions in the echo area.")
    182 
    183 (defface company-echo-common
    184   '((((background light)) (:foreground "firebrick4"))
    185     (((background dark)) (:foreground "firebrick1")))
    186   "Face used for the common part of completions in the echo area.")
    187 
    188 ;; Too lazy to re-add :group to all defcustoms down below.
    189 (setcdr (assoc load-file-name custom-current-group-alist)
    190         'company)
    191 
    192 (defun company-frontends-set (variable value)
    193   ;; Uniquify.
    194   (let ((value (delete-dups (copy-sequence value))))
    195     (and (or (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
    196                   (memq 'company-pseudo-tooltip-frontend value))
    197              (and (memq 'company-pseudo-tooltip-unless-just-one-frontend-with-delay value)
    198                   (memq 'company-pseudo-tooltip-frontend value))
    199              (and (memq 'company-pseudo-tooltip-unless-just-one-frontend-with-delay value)
    200                   (memq 'company-pseudo-tooltip-unless-just-one-frontend value)))
    201          (user-error "Pseudo tooltip frontend cannot be used more than once"))
    202     (and (or (and (memq 'company-preview-if-just-one-frontend value)
    203                   (memq 'company-preview-frontend value))
    204              (and (memq 'company-preview-if-just-one-frontend value)
    205                   (memq 'company-preview-common-frontend value))
    206              (and (memq 'company-preview-frontend value)
    207                   (memq 'company-preview-common-frontend value))
    208              )
    209          (user-error "Preview frontend cannot be used twice"))
    210     (and (memq 'company-echo value)
    211          (memq 'company-echo-metadata-frontend value)
    212          (user-error "Echo area cannot be used twice"))
    213     ;; Preview must come last.
    214     (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend company-preview-common-frontend))
    215       (when (cdr (memq f value))
    216         (setq value (append (delq f value) (list f)))))
    217     (set variable value)))
    218 
    219 (defcustom company-frontends '(company-pseudo-tooltip-unless-just-one-frontend
    220                                company-preview-if-just-one-frontend
    221                                company-echo-metadata-frontend)
    222   "The list of active frontends (visualizations).
    223 Each frontend is a function that takes one argument.  It is called with
    224 one of the following arguments:
    225 
    226 `show': When the visualization should start.
    227 
    228 `hide': When the visualization should end.
    229 
    230 `update': When the data has been updated.
    231 
    232 `pre-command': Before every command that is executed while the
    233 visualization is active.
    234 
    235 `post-command': After every command that is executed while the
    236 visualization is active.
    237 
    238 `unhide': When an asynchronous backend is waiting for its completions.
    239 Only needed in frontends which hide their visualizations in `pre-command'
    240 for technical reasons.
    241 
    242 The visualized data is stored in `company-prefix', `company-candidates',
    243 `company-common', `company-selection', `company-point' and
    244 `company-search-string'."
    245   :set 'company-frontends-set
    246   :type '(repeat (choice (const :tag "echo" company-echo-frontend)
    247                          (const :tag "echo, strip common"
    248                                 company-echo-strip-common-frontend)
    249                          (const :tag "show echo meta-data in echo"
    250                                 company-echo-metadata-frontend)
    251                          (const :tag "pseudo tooltip"
    252                                 company-pseudo-tooltip-frontend)
    253                          (const :tag "pseudo tooltip, multiple only"
    254                                 company-pseudo-tooltip-unless-just-one-frontend)
    255                          (const :tag "pseudo tooltip, multiple only, delayed"
    256                                 company-pseudo-tooltip-unless-just-one-frontend-with-delay)
    257                          (const :tag "preview" company-preview-frontend)
    258                          (const :tag "preview, unique only"
    259                                 company-preview-if-just-one-frontend)
    260                          (const :tag "preview, common"
    261                                 company-preview-common-frontend)
    262                          (function :tag "custom function" nil))))
    263 
    264 (defcustom company-tooltip-limit 10
    265   "The maximum number of candidates in the tooltip."
    266   :type 'integer)
    267 
    268 (defcustom company-tooltip-minimum 6
    269   "Ensure visibility of this number of candidates.
    270 When that many lines are not available between point and the bottom of the
    271 window, display the tooltip above point."
    272   :type 'integer)
    273 
    274 (defcustom company-tooltip-minimum-width 0
    275   "The minimum width of the tooltip's inner area.
    276 This doesn't include the margins and the scroll bar."
    277   :type 'integer
    278   :package-version '(company . "0.8.0"))
    279 
    280 (defcustom company-tooltip-maximum-width most-positive-fixnum
    281   "The maximum width of the tooltip's inner area.
    282 This doesn't include the margins and the scroll bar."
    283   :type 'integer
    284   :package-version '(company . "0.9.5"))
    285 
    286 (defcustom company-tooltip-width-grow-only nil
    287   "When non-nil, the tooltip width is not allowed to decrease."
    288   :type 'boolean
    289   :package-version '(company . "0.10.0"))
    290 
    291 (defcustom company-tooltip-margin 1
    292   "Width of margin columns to show around the toolip."
    293   :type 'integer)
    294 
    295 (defcustom company-tooltip-offset-display 'scrollbar
    296   "Method using which the tooltip displays scrolling position.
    297 `scrollbar' means draw a scrollbar to the right of the items.
    298 `lines' means wrap items in lines with \"before\" and \"after\" counters."
    299   :type '(choice (const :tag "Scrollbar" scrollbar)
    300                  (const :tag "Two lines" lines)))
    301 
    302 (defcustom company-tooltip-align-annotations nil
    303   "When non-nil, align annotations to the right tooltip border."
    304   :type 'boolean
    305   :package-version '(company . "0.7.1"))
    306 
    307 (defcustom company-tooltip-flip-when-above nil
    308   "Whether to flip the tooltip when it's above the current line."
    309   :type 'boolean
    310   :package-version '(company . "0.8.1"))
    311 
    312 (defcustom company-tooltip-annotation-padding nil
    313   "Non-nil to specify the padding before annotation.
    314 
    315 Depending on the value of `company-tooltip-align-annotations', the default
    316 padding is either 0 or 1 space.  This variable allows to override that
    317 value to increase the padding.  When annotations are right-aligned, it sets
    318 the minimum padding, and otherwise just the constant one."
    319   :type 'number
    320   :package-version '(company "0.10.0"))
    321 
    322 (defvar company-safe-backends
    323   '((company-abbrev . "Abbrev")
    324     (company-bbdb . "BBDB")
    325     (company-capf . "completion-at-point-functions")
    326     (company-clang . "Clang")
    327     (company-cmake . "CMake")
    328     (company-css . "CSS (obsolete backend)")
    329     (company-dabbrev . "dabbrev for plain text")
    330     (company-dabbrev-code . "dabbrev for code")
    331     (company-elisp . "Emacs Lisp (obsolete backend)")
    332     (company-etags . "etags")
    333     (company-files . "Files")
    334     (company-gtags . "GNU Global")
    335     (company-ispell . "Ispell")
    336     (company-keywords . "Programming language keywords")
    337     (company-nxml . "nxml (obsolete backend)")
    338     (company-oddmuse . "Oddmuse")
    339     (company-semantic . "Semantic")
    340     (company-tempo . "Tempo templates")))
    341 (put 'company-safe-backends 'risky-local-variable t)
    342 
    343 (defun company-safe-backends-p (backends)
    344   (and (consp backends)
    345        (not (cl-dolist (backend backends)
    346               (unless (if (consp backend)
    347                           (company-safe-backends-p backend)
    348                         (assq backend company-safe-backends))
    349                 (cl-return t))))))
    350 
    351 (defcustom company-backends `(company-bbdb
    352                               ,@(unless (version<= "26" emacs-version)
    353                                   (list 'company-nxml))
    354                               ,@(unless (version<= "26" emacs-version)
    355                                   (list 'company-css))
    356                               company-semantic
    357                               company-cmake
    358                               company-capf
    359                               company-clang
    360                               company-files
    361                               (company-dabbrev-code company-gtags company-etags
    362                                company-keywords)
    363                               company-oddmuse company-dabbrev)
    364   "The list of active backends (completion engines).
    365 
    366 Only one backend is used at a time.  The choice depends on the order of
    367 the items in this list, and on the values they return in response to the
    368 `prefix' command (see below).  But a backend can also be a \"grouped\"
    369 one (see below).
    370 
    371 `company-begin-backend' can be used to start a specific backend,
    372 `company-other-backend' will skip to the next matching backend in the list.
    373 
    374 Each backend is a function that takes a variable number of arguments.
    375 The first argument is the command requested from the backend.  It is one
    376 of the following:
    377 
    378 `prefix': The backend should return the text to be completed.  It must be
    379 text immediately before point.  Returning nil from this command passes
    380 control to the next backend.  The function should return `stop' if it
    381 should complete but cannot (e.g. when in the middle of a symbol).
    382 Instead of a string, the backend may return a cons (PREFIX . LENGTH)
    383 where LENGTH is a number used in place of PREFIX's length when
    384 comparing against `company-minimum-prefix-length'.  LENGTH can also
    385 be just t, and in the latter case the test automatically succeeds.
    386 
    387 `candidates': The second argument is the prefix to be completed.  The
    388 return value should be a list of candidates that match the prefix.
    389 
    390 Non-prefix matches are also supported (candidates that don't start with the
    391 prefix, but match it in some backend-defined way).  Backends that use this
    392 feature must disable cache (return t to `no-cache') and might also want to
    393 respond to `match'.
    394 
    395 Optional commands
    396 =================
    397 
    398 `sorted': Return t here to indicate that the candidates are sorted and will
    399 not need to be sorted again.
    400 
    401 `duplicates': If non-nil, company will take care of removing duplicates
    402 from the list.
    403 
    404 `no-cache': Usually company doesn't ask for candidates again as completion
    405 progresses, unless the backend returns t for this command.  The second
    406 argument is the latest prefix.
    407 
    408 `ignore-case': Return t here if the backend returns case-insensitive
    409 matches.  This value is used to determine the longest common prefix (as
    410 used in `company-complete-common'), and to filter completions when fetching
    411 them from cache.
    412 
    413 `meta': The second argument is a completion candidate.  Return a (short)
    414 documentation string for it.
    415 
    416 `doc-buffer': The second argument is a completion candidate.  Return a
    417 buffer with documentation for it.  Preferably use `company-doc-buffer'.  If
    418 not all buffer contents pertain to this candidate, return a cons of buffer
    419 and window start position.
    420 
    421 `location': The second argument is a completion candidate.  Return a cons
    422 of buffer and buffer location, or of file and line number where the
    423 completion candidate was defined.
    424 
    425 `annotation': The second argument is a completion candidate.  Return a
    426 string to be displayed inline with the candidate in the popup.  If
    427 duplicates are removed by company, candidates with equal string values will
    428 be kept if they have different annotations.  For that to work properly,
    429 backends should store the related information on candidates using text
    430 properties.
    431 
    432 `deprecated': The second argument is a completion candidate.  Return
    433 non-nil if the completion candidate is deprecated.
    434 
    435 `match': The second argument is a completion candidate.  Return a positive
    436 integer, the index after the end of text matching `prefix' within the
    437 candidate string.  Alternatively, return a list of (CHUNK-START
    438 . CHUNK-END) elements, where CHUNK-START and CHUNK-END are indexes within
    439 the candidate string.  The corresponding regions are be used when rendering
    440 the popup.  This command only makes sense for backends that provide
    441 non-prefix completion.
    442 
    443 `require-match': If this returns t, the user is not allowed to enter
    444 anything not offered as a candidate.  Please don't use that value in normal
    445 backends.  The default value nil gives the user that choice with
    446 `company-require-match'.  Return value `never' overrides that option the
    447 other way around (using that value will indicate that the returned set of
    448 completions is often incomplete, so this behavior will not be useful).
    449 
    450 `init': Called once for each buffer. The backend can check for external
    451 programs and files and load any required libraries.  Raising an error here
    452 will show up in message log once, and the backend will not be used for
    453 completion.
    454 
    455 `post-completion': Called after a completion candidate has been inserted
    456 into the buffer.  The second argument is the candidate.  Can be used to
    457 modify it, e.g. to expand a snippet.
    458 
    459 `kind': The second argument is a completion candidate.  Return a symbol
    460 describing the kind of the candidate.  Refer to `company-vscode-icons-mapping'
    461 for the possible values.
    462 
    463 The backend should return nil for all commands it does not support or
    464 does not know about.  It should also be callable interactively and use
    465 `company-begin-backend' to start itself in that case.
    466 
    467 Grouped backends
    468 ================
    469 
    470 An element of `company-backends' can also be a list of backends.  The
    471 completions from backends in such groups are merged, but only from those
    472 backends which return the same `prefix'.
    473 
    474 If a backend command takes a candidate as an argument (e.g. `meta'), the
    475 call is dispatched to the backend the candidate came from.  In other
    476 cases (except for `duplicates' and `sorted'), the first non-nil value among
    477 all the backends is returned.
    478 
    479 The group can also contain keywords.  Currently, `:with' and `:separate'
    480 keywords are defined.  If the group contains keyword `:with', the backends
    481 listed after this keyword are ignored for the purpose of the `prefix'
    482 command.  If the group contains keyword `:separate', the candidates that
    483 come from different backends are sorted separately in the combined list.
    484 
    485 Asynchronous backends
    486 =====================
    487 
    488 The return value of each command can also be a cons (:async . FETCHER)
    489 where FETCHER is a function of one argument, CALLBACK.  When the data
    490 arrives, FETCHER must call CALLBACK and pass it the appropriate return
    491 value, as described above.  That call must happen in the same buffer as
    492 where completion was initiated.
    493 
    494 True asynchronous operation is only supported for command `candidates', and
    495 only during idle completion.  Other commands will block the user interface,
    496 even if the backend uses the asynchronous calling convention."
    497   :type `(repeat
    498           (choice
    499            :tag "backend"
    500            ,@(mapcar (lambda (b) `(const :tag ,(cdr b) ,(car b)))
    501                      company-safe-backends)
    502            (symbol :tag "User defined")
    503            (repeat :tag "Merged backends"
    504                    (choice :tag "backend"
    505                            ,@(mapcar (lambda (b)
    506                                        `(const :tag ,(cdr b) ,(car b)))
    507                                      company-safe-backends)
    508                            (const :tag "With" :with)
    509                            (symbol :tag "User defined"))))))
    510 
    511 (put 'company-backends 'safe-local-variable 'company-safe-backends-p)
    512 
    513 (defcustom company-transformers nil
    514   "Functions to change the list of candidates received from backends.
    515 
    516 Each function gets called with the return value of the previous one.
    517 The first one gets passed the list of candidates, already sorted and
    518 without duplicates."
    519   :type '(choice
    520           (const :tag "None" nil)
    521           (const :tag "Sort by occurrence" (company-sort-by-occurrence))
    522           (const :tag "Sort by backend importance"
    523                  (company-sort-by-backend-importance))
    524           (const :tag "Prefer case sensitive prefix"
    525                  (company-sort-prefer-same-case-prefix))
    526           (repeat :tag "User defined" function)))
    527 
    528 (defcustom company-completion-started-hook nil
    529   "Hook run when company starts completing.
    530 The hook is called with one argument that is non-nil if the completion was
    531 started manually."
    532   :type 'hook)
    533 
    534 (defcustom company-completion-cancelled-hook nil
    535   "Hook run when company cancels completing.
    536 The hook is called with one argument that is non-nil if the completion was
    537 aborted manually."
    538   :type 'hook)
    539 
    540 (defcustom company-completion-finished-hook nil
    541   "Hook run when company successfully completes.
    542 The hook is called with the selected candidate as an argument.
    543 
    544 If you indend to use it to post-process candidates from a specific
    545 backend, consider using the `post-completion' command instead."
    546   :type 'hook)
    547 
    548 (defcustom company-after-completion-hook nil
    549   "Hook run at the end of completion, successful or not.
    550 The hook is called with one argument which is either a string or a symbol."
    551   :type 'hook)
    552 
    553 (defcustom company-minimum-prefix-length 3
    554   "The minimum prefix length for idle completion."
    555   :type '(integer :tag "prefix length"))
    556 
    557 (defcustom company-abort-manual-when-too-short nil
    558   "If enabled, cancel a manually started completion when the prefix gets
    559 shorter than both `company-minimum-prefix-length' and the length of the
    560 prefix it was started from."
    561   :type 'boolean
    562   :package-version '(company . "0.8.0"))
    563 
    564 (defcustom company-abort-on-unique-match t
    565   "If non-nil, typing a full unique match aborts completion.
    566 
    567 You can still invoke `company-complete' manually to run the
    568 `post-completion' handler, though.
    569 
    570 If it's nil, completion will remain active until you type a prefix that
    571 doesn't match anything or finish it manually, e.g. with RET."
    572   :type 'boolean)
    573 
    574 (defcustom company-require-match 'company-explicit-action-p
    575   "If enabled, disallow non-matching input.
    576 This can be a function do determine if a match is required.
    577 
    578 This can be overridden by the backend, if it returns t or `never' to
    579 `require-match'.  `company-insertion-on-trigger' also takes precedence over
    580 this."
    581   :type '(choice (const :tag "Off" nil)
    582                  (function :tag "Predicate function")
    583                  (const :tag "On, if user interaction took place"
    584                         company-explicit-action-p)
    585                  (const :tag "On" t)))
    586 
    587 (define-obsolete-variable-alias
    588   'company-auto-complete
    589   'company-insertion-on-trigger
    590   "0.10.0")
    591 
    592 (define-obsolete-variable-alias
    593   'company-auto-commit
    594   'company-insertion-on-trigger
    595   "0.10.0")
    596 
    597 (defcustom company-insertion-on-trigger nil
    598   "If enabled, allow triggering insertion of the selected candidate.
    599 This can also be a predicate function, for example,
    600 `company-explicit-action-p'.
    601 
    602 See `company-insertion-triggers' for more details on how to define
    603 triggers."
    604   :type '(choice (const :tag "Off" nil)
    605                  (function :tag "Predicate function")
    606                  (const :tag "On, if user interaction took place"
    607                         company-explicit-action-p)
    608                  (const :tag "On" t))
    609   :package-version '(company . "0.10.0"))
    610 
    611 (define-obsolete-variable-alias
    612   'company-auto-complete-chars
    613   'company-insertion-triggers
    614   "0.10.0")
    615 
    616 (define-obsolete-variable-alias
    617   'company-auto-commit-chars
    618   'company-insertion-triggers
    619   "0.10.0")
    620 
    621 (defcustom company-insertion-triggers '(?\  ?\) ?.)
    622   "Determine triggers for `company-insertion-on-trigger'.
    623 
    624 If this is a string, then each character in it can trigger insertion of the
    625 selected candidate.  If it is a list of syntax description characters (see
    626 `modify-syntax-entry'), then characters with any of those syntaxes can act
    627 as triggers.
    628 
    629 This can also be a function, which is called with the new input.  To
    630 trigger insertion, the function should return a non-nil value.
    631 
    632 Note that a character that is part of a valid completion never triggers
    633 insertion."
    634   :type '(choice (string :tag "Characters")
    635                  (set :tag "Syntax"
    636                       (const :tag "Whitespace" ?\ )
    637                       (const :tag "Symbol" ?_)
    638                       (const :tag "Opening parentheses" ?\()
    639                       (const :tag "Closing parentheses" ?\))
    640                       (const :tag "Word constituent" ?w)
    641                       (const :tag "Punctuation." ?.)
    642                       (const :tag "String quote." ?\")
    643                       (const :tag "Paired delimiter." ?$)
    644                       (const :tag "Expression quote or prefix operator." ?\')
    645                       (const :tag "Comment starter." ?<)
    646                       (const :tag "Comment ender." ?>)
    647                       (const :tag "Character-quote." ?/)
    648                       (const :tag "Generic string fence." ?|)
    649                       (const :tag "Generic comment fence." ?!))
    650                  (function :tag "Predicate function"))
    651   :package-version '(company . "0.10.0"))
    652 
    653 (defcustom company-idle-delay .2
    654   "The idle delay in seconds until completion starts automatically.
    655 The prefix still has to satisfy `company-minimum-prefix-length' before that
    656 happens.  The value of nil means no idle completion."
    657   :type '(choice (const :tag "never (nil)" nil)
    658                  (const :tag "immediate (0)" 0)
    659                  (function :tag "Predicate function")
    660                  (number :tag "seconds")))
    661 
    662 (defcustom company-tooltip-idle-delay .5
    663   "The idle delay in seconds until tooltip is shown when using
    664 `company-pseudo-tooltip-unless-just-one-frontend-with-delay'."
    665   :type '(choice (const :tag "never (nil)" nil)
    666                  (const :tag "immediate (0)" 0)
    667                  (number :tag "seconds")))
    668 
    669 (defcustom company-begin-commands '(self-insert-command
    670                                     org-self-insert-command
    671                                     orgtbl-self-insert-command
    672                                     c-scope-operator
    673                                     c-electric-colon
    674                                     c-electric-lt-gt
    675                                     c-electric-slash)
    676   "A list of commands after which idle completion is allowed.
    677 If this is t, it can show completions after any command except a few from a
    678 pre-defined list.  See `company-idle-delay'.
    679 
    680 Alternatively, any command with a non-nil `company-begin' property is
    681 treated as if it was on this list."
    682   :type '(choice (const :tag "Any command" t)
    683                  (const :tag "Self insert command" (self-insert-command))
    684                  (repeat :tag "Commands" function))
    685   :package-version '(company . "0.8.4"))
    686 
    687 (defcustom company-continue-commands '(not save-buffer save-some-buffers
    688                                            save-buffers-kill-terminal
    689                                            save-buffers-kill-emacs
    690                                            completion-at-point)
    691   "A list of commands that are allowed during completion.
    692 If this is t, or if `company-begin-commands' is t, any command is allowed.
    693 Otherwise, the value must be a list of symbols.  If it starts with `not',
    694 the cdr is the list of commands that abort completion.  Otherwise, all
    695 commands except those in that list, or in `company-begin-commands', or
    696 commands in the `company-' namespace, abort completion."
    697   :type '(choice (const :tag "Any command" t)
    698                  (cons  :tag "Any except"
    699                         (const not)
    700                         (repeat :tag "Commands" function))
    701                  (repeat :tag "Commands" function)))
    702 
    703 (defun company-custom--set-quick-access (option value)
    704   "Re-bind quick-access key sequences on OPTION VALUE change."
    705   ;; When upgrading from an earlier version of company, might not be.
    706   (when (fboundp #'company-keymap--unbind-quick-access)
    707     (when (boundp 'company-active-map)
    708       (company-keymap--unbind-quick-access company-active-map))
    709     (when (boundp 'company-search-map)
    710       (company-keymap--unbind-quick-access company-search-map)))
    711   (custom-set-default option value)
    712   (when (fboundp #'company-keymap--bind-quick-access)
    713     (when (boundp 'company-active-map)
    714       (company-keymap--bind-quick-access company-active-map))
    715     (when (boundp 'company-search-map)
    716       (company-keymap--bind-quick-access company-search-map))))
    717 
    718 (defcustom company-quick-access-keys '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
    719   "Character strings used as a part of quick-access key sequences.
    720 To change this value without Customize interface, use `customize-set-variable'.
    721 
    722 To change the quick-access key sequences modifier, customize
    723 `company-quick-access-modifier'.
    724 
    725 If `company-show-quick-access' is non-nil, show quick-access hints
    726 beside the candidates."
    727   :set #'company-custom--set-quick-access
    728   :type '(choice
    729           (const :tag "Digits" ("1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
    730           (const :tag "QWERTY home row" ("a" "s" "d" "f" "g" "h" "j" "k" "l" ";"))
    731           ;; TODO un-comment on removal of `M-n' `company--select-next-and-warn'.
    732           ;; (const :tag "Dvorak home row" ("a" "o" "e" "u" "i" "d" "h" "t" "n" "s"))
    733           (repeat :tag "User defined" string))
    734   :package-version '(company . "0.10.0"))
    735 
    736 (defcustom company-quick-access-modifier 'meta
    737   "Modifier key used for quick-access keys sequences.
    738 To change this value without Customize interface, use `customize-set-variable'.
    739 See `company-quick-access-keys' for more details."
    740   :set #'company-custom--set-quick-access
    741   :type '(choice (const :tag "Meta key" meta)
    742                  (const :tag "Super key" super)
    743                  (const :tag "Hyper key" hyper)
    744                  (const :tag "Control key" control))
    745   :package-version '(company . "0.10.0"))
    746 
    747 (defun company-keymap--quick-access-modifier ()
    748   "Return string representation of the `company-quick-access-modifier'."
    749   (if-let ((modifier (assoc-default company-quick-access-modifier
    750                                     '((meta . "M")
    751                                       (super . "s")
    752                                       (hyper . "H")
    753                                       (control . "C")))))
    754       modifier
    755     (warn "company-quick-access-modifier value unknown: %S"
    756           company-quick-access-modifier)
    757     "M"))
    758 
    759 (defun company-keymap--unbind-quick-access (keymap)
    760   (let ((modifier (company-keymap--quick-access-modifier)))
    761     (dolist (key company-quick-access-keys)
    762       (let ((key-seq (company-keymap--kbd-quick-access modifier key)))
    763         (when (equal (lookup-key keymap key-seq) 'company-complete-quick-access)
    764           (define-key keymap key-seq nil))))))
    765 
    766 (defun company-keymap--bind-quick-access (keymap)
    767   (let ((modifier (company-keymap--quick-access-modifier)))
    768     (dolist (key company-quick-access-keys)
    769       (let ((key-seq (company-keymap--kbd-quick-access modifier key)))
    770         (if (lookup-key keymap key-seq)
    771             (warn "Key sequence %s already bound" (key-description key-seq))
    772           (define-key keymap key-seq #'company-complete-quick-access))))))
    773 
    774 (defun company-keymap--kbd-quick-access (modifier key)
    775   (kbd (format "%s-%s" modifier key)))
    776 
    777 (define-obsolete-variable-alias
    778   'company-show-numbers
    779   'company-show-quick-access
    780   "0.10.0")
    781 
    782 (defcustom company-show-quick-access nil
    783   "If non-nil, show quick-access hints beside the candidates.
    784 
    785 For a tooltip frontend, non-nil value enables a column with the hints
    786 on the right side of the tooltip, unless the configured value is `left'.
    787 
    788 To change the quick-access key bindings, customize `company-quick-access-keys'
    789 and `company-quick-access-modifier'.
    790 
    791 To change the shown quick-access hints, customize
    792 `company-quick-access-hint-function'."
    793   :type '(choice (const :tag "off" nil)
    794                  (const :tag "left" left)
    795                  (const :tag "on" t)))
    796 
    797 (defcustom company-show-numbers-function nil
    798   "Function called to get quick-access numbers for the first ten candidates.
    799 
    800 The function receives the candidate number (starting from 1) and should
    801 return a string prefixed with one space."
    802   :type 'function)
    803 (make-obsolete-variable
    804  'company-show-numbers-function
    805  "use `company-quick-access-hint-function' instead,
    806 but adjust the expected values appropriately."
    807  "0.10.0")
    808 
    809 (defcustom company-quick-access-hint-function #'company-quick-access-hint-key
    810   "Function called to get quick-access hints for the candidates.
    811 
    812 The function receives a candidate's 0-based number
    813 and should return a string.
    814 See `company-show-quick-access' for more details."
    815   :type 'function)
    816 
    817 (defun company-quick-access-hint-key (candidate)
    818   "Return a quick-access key for the CANDIDATE number.
    819 This is a default value of `company-quick-access-hint-function'."
    820   (if company-show-numbers-function
    821       (funcall company-show-numbers-function (1+ candidate))
    822     (format "%s"
    823             (if (< candidate (length company-quick-access-keys))
    824                 (nth candidate company-quick-access-keys)
    825               ""))))
    826 
    827 (defcustom company-selection-wrap-around nil
    828   "If enabled, selecting item before first or after last wraps around."
    829   :type '(choice (const :tag "off" nil)
    830                  (const :tag "on" t)))
    831 
    832 (defcustom company-async-redisplay-delay 0.005
    833   "Delay before redisplay when fetching candidates asynchronously.
    834 
    835 You might want to set this to a higher value if your backends respond
    836 quickly, to avoid redisplaying twice per each typed character."
    837   :type 'number)
    838 
    839 (defvar company-async-wait 0.03
    840   "Pause between checks to see if the value's been set when turning an
    841 asynchronous call into synchronous.")
    842 
    843 (defvar company-async-timeout 2
    844   "Maximum wait time for a value to be set during asynchronous call.")
    845 
    846 ;;; mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    847 
    848 (defvar company-mode-map (make-sparse-keymap)
    849   "Keymap used by `company-mode'.")
    850 
    851 (defvar company-active-map
    852   (let ((keymap (make-sparse-keymap)))
    853     (define-key keymap "\e\e\e" 'company-abort)
    854     (define-key keymap "\C-g" 'company-abort)
    855     (define-key keymap (kbd "M-n") 'company--select-next-and-warn)
    856     (define-key keymap (kbd "M-p") 'company--select-previous-and-warn)
    857     (define-key keymap (kbd "C-n") 'company-select-next-or-abort)
    858     (define-key keymap (kbd "C-p") 'company-select-previous-or-abort)
    859     (define-key keymap (kbd "<down>") 'company-select-next-or-abort)
    860     (define-key keymap (kbd "<up>") 'company-select-previous-or-abort)
    861     (define-key keymap [remap scroll-up-command] 'company-next-page)
    862     (define-key keymap [remap scroll-down-command] 'company-previous-page)
    863     (define-key keymap [down-mouse-1] 'ignore)
    864     (define-key keymap [down-mouse-3] 'ignore)
    865     (define-key keymap [mouse-1] 'company-complete-mouse)
    866     (define-key keymap [mouse-3] 'company-select-mouse)
    867     (define-key keymap [up-mouse-1] 'ignore)
    868     (define-key keymap [up-mouse-3] 'ignore)
    869     (define-key keymap [return] 'company-complete-selection)
    870     (define-key keymap (kbd "RET") 'company-complete-selection)
    871     (define-key keymap [tab] 'company-complete-common)
    872     (define-key keymap (kbd "TAB") 'company-complete-common)
    873     (define-key keymap (kbd "<f1>") 'company-show-doc-buffer)
    874     (define-key keymap (kbd "C-h") 'company-show-doc-buffer)
    875     (define-key keymap "\C-w" 'company-show-location)
    876     (define-key keymap "\C-s" 'company-search-candidates)
    877     (define-key keymap "\C-\M-s" 'company-filter-candidates)
    878     (company-keymap--bind-quick-access keymap)
    879      keymap)
    880   "Keymap that is enabled during an active completion.")
    881 
    882 (defvar company--disabled-backends nil)
    883 
    884 (defun company--select-next-and-warn (&optional arg)
    885   (interactive "p")
    886   (company--warn-changed-binding)
    887   (company-select-next arg))
    888 
    889 (defun company--select-previous-and-warn (&optional arg)
    890   (interactive "p")
    891   (company--warn-changed-binding)
    892   (company-select-previous arg))
    893 
    894 (defun company--warn-changed-binding ()
    895   (interactive)
    896   (run-with-idle-timer
    897    0.01 nil
    898    (lambda ()
    899      (message "Warning: default bindings are being changed to C-n and C-p"))))
    900 
    901 (defun company-init-backend (backend)
    902   (and (symbolp backend)
    903        (not (fboundp backend))
    904        (ignore-errors (require backend nil t)))
    905   (cond
    906    ((symbolp backend)
    907     (condition-case err
    908         (progn
    909           (funcall backend 'init)
    910           (put backend 'company-init t))
    911       (error
    912        (put backend 'company-init 'failed)
    913        (unless (memq backend company--disabled-backends)
    914          (message "Company backend '%s' could not be initialized:\n%s"
    915                   backend (error-message-string err)))
    916        (cl-pushnew backend company--disabled-backends)
    917        nil)))
    918    ;; No initialization for lambdas.
    919    ((functionp backend) t)
    920    (t ;; Must be a list.
    921     (cl-dolist (b backend)
    922       (unless (keywordp b)
    923         (company-init-backend b))))))
    924 
    925 (defun company--maybe-init-backend (backend)
    926   (or (not (symbolp backend))
    927       (eq t (get backend 'company-init))
    928       (unless (get backend 'company-init)
    929         (company-init-backend backend))))
    930 
    931 (defcustom company-lighter-base "company"
    932   "Base string to use for the `company-mode' lighter."
    933   :type 'string
    934   :package-version '(company . "0.8.10"))
    935 
    936 (defvar company-lighter '(" "
    937                           (company-candidates
    938                            (:eval
    939                             (if (consp company-backend)
    940                                 (when company-selection
    941                                   (company--group-lighter (nth company-selection
    942                                                                company-candidates)
    943                                                           company-lighter-base))
    944                               (symbol-name company-backend)))
    945                            company-lighter-base))
    946   "Mode line lighter for Company.
    947 
    948 The value of this variable is a mode line template as in
    949 `mode-line-format'.")
    950 
    951 (put 'company-lighter 'risky-local-variable t)
    952 
    953 ;;;###autoload
    954 (define-minor-mode company-mode
    955   "\"complete anything\"; is an in-buffer completion framework.
    956 Completion starts automatically, depending on the values
    957 `company-idle-delay' and `company-minimum-prefix-length'.
    958 
    959 Completion can be controlled with the commands:
    960 `company-complete-common', `company-complete-selection', `company-complete',
    961 `company-select-next', `company-select-previous'.  If these commands are
    962 called before `company-idle-delay', completion will also start.
    963 
    964 Completions can be searched with `company-search-candidates' or
    965 `company-filter-candidates'.  These can be used while completion is
    966 inactive, as well.
    967 
    968 The completion data is retrieved using `company-backends' and displayed
    969 using `company-frontends'.  If you want to start a specific backend, call
    970 it interactively or use `company-begin-backend'.
    971 
    972 By default, the completions list is sorted alphabetically, unless the
    973 backend chooses otherwise, or `company-transformers' changes it later.
    974 
    975 regular keymap (`company-mode-map'):
    976 
    977 \\{company-mode-map}
    978 keymap during active completions (`company-active-map'):
    979 
    980 \\{company-active-map}"
    981   :lighter company-lighter
    982   (if company-mode
    983       (progn
    984         (add-hook 'pre-command-hook 'company-pre-command nil t)
    985         (add-hook 'post-command-hook 'company-post-command nil t)
    986         (add-hook 'yas-keymap-disable-hook 'company--active-p nil t)
    987         (mapc 'company-init-backend company-backends))
    988     (remove-hook 'pre-command-hook 'company-pre-command t)
    989     (remove-hook 'post-command-hook 'company-post-command t)
    990     (remove-hook 'yas-keymap-disable-hook 'company--active-p t)
    991     (company-cancel)
    992     (kill-local-variable 'company-point)))
    993 
    994 (defcustom company-global-modes t
    995   "Modes for which `company-mode' mode is turned on by `global-company-mode'.
    996 If nil, means no modes.  If t, then all major modes have it turned on.
    997 If a list, it should be a list of `major-mode' symbol names for which
    998 `company-mode' should be automatically turned on.  The sense of the list is
    999 negated if it begins with `not'.  For example:
   1000  (c-mode c++-mode)
   1001 means that `company-mode' is turned on for buffers in C and C++ modes only.
   1002  (not message-mode)
   1003 means that `company-mode' is always turned on except in `message-mode' buffers."
   1004   :type '(choice (const :tag "none" nil)
   1005                  (const :tag "all" t)
   1006                  (set :menu-tag "mode specific" :tag "modes"
   1007                       :value (not)
   1008                       (const :tag "Except" not)
   1009                       (repeat :inline t (symbol :tag "mode")))))
   1010 
   1011 ;;;###autoload
   1012 (define-globalized-minor-mode global-company-mode company-mode company-mode-on)
   1013 
   1014 (defun company-mode-on ()
   1015   (when (and (not (or noninteractive (eq (aref (buffer-name) 0) ?\s)))
   1016              (cond ((eq company-global-modes t)
   1017                     t)
   1018                    ((eq (car-safe company-global-modes) 'not)
   1019                     (not (memq major-mode (cdr company-global-modes))))
   1020                    (t (memq major-mode company-global-modes))))
   1021     (company-mode 1)))
   1022 
   1023 (defsubst company-assert-enabled ()
   1024   (unless company-mode
   1025     (company-uninstall-map)
   1026     (user-error "Company not enabled")))
   1027 
   1028 ;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1029 
   1030 (defvar-local company-my-keymap nil)
   1031 
   1032 (defvar company-emulation-alist '((t . nil)))
   1033 
   1034 (defun company-enable-overriding-keymap (keymap)
   1035   (company-uninstall-map)
   1036   (setq company-my-keymap keymap))
   1037 
   1038 (defun company-ensure-emulation-alist ()
   1039   (unless (eq 'company-emulation-alist (car emulation-mode-map-alists))
   1040     (setq emulation-mode-map-alists
   1041           (cons 'company-emulation-alist
   1042                 (delq 'company-emulation-alist emulation-mode-map-alists)))))
   1043 
   1044 (defun company-install-map ()
   1045   (unless (or (cdar company-emulation-alist)
   1046               (null company-my-keymap))
   1047     (setf (cdar company-emulation-alist) company-my-keymap)))
   1048 
   1049 (defun company-uninstall-map ()
   1050   (setf (cdar company-emulation-alist) nil))
   1051 
   1052 (defun company--company-command-p (keys)
   1053   "Checks if the keys are part of company's overriding keymap"
   1054   (or (equal [company-dummy-event] keys)
   1055       (commandp (lookup-key company-my-keymap keys))))
   1056 
   1057 ;; To avoid warnings in Emacs < 26.
   1058 (declare-function line-number-display-width "indent.c")
   1059 
   1060 (defun company--posn-col-row (posn)
   1061   (let ((col (car (posn-col-row posn)))
   1062         ;; `posn-col-row' doesn't work well with lines of different height.
   1063         ;; `posn-actual-col-row' doesn't handle multiple-width characters.
   1064         (row (cdr (or (posn-actual-col-row posn)
   1065                       ;; When position is non-visible for some reason.
   1066                       (posn-col-row posn)))))
   1067     ;; posn-col-row return value relative to the left
   1068     (when (eq (current-bidi-paragraph-direction) 'right-to-left)
   1069       (let ((ww (window-body-width)))
   1070         (setq col (- ww col))))
   1071     (when (bound-and-true-p display-line-numbers)
   1072       (cl-decf col (+ 2 (line-number-display-width))))
   1073     (cons (+ col (window-hscroll)) row)))
   1074 
   1075 (defun company--col-row (&optional pos)
   1076   (company--posn-col-row (posn-at-point pos)))
   1077 
   1078 (defun company--row (&optional pos)
   1079   (cdr (company--col-row pos)))
   1080 
   1081 ;;; backends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1082 
   1083 (defvar-local company-backend nil)
   1084 
   1085 (defun company-grab (regexp &optional expression limit)
   1086   (when (looking-back regexp limit)
   1087     (or (match-string-no-properties (or expression 0)) "")))
   1088 
   1089 (defun company-grab-line (regexp &optional expression)
   1090   "Return a match string for REGEXP if it matches text before point.
   1091 If EXPRESSION is non-nil, return the match string for the respective
   1092 parenthesized expression in REGEXP.
   1093 Matching is limited to the current line."
   1094   (let ((inhibit-field-text-motion t))
   1095     (company-grab regexp expression (line-beginning-position))))
   1096 
   1097 (defun company-grab-symbol ()
   1098   "If point is at the end of a symbol, return it.
   1099 Otherwise, if point is not inside a symbol, return an empty string."
   1100   (if (looking-at "\\_>")
   1101       (buffer-substring (point) (save-excursion (skip-syntax-backward "w_")
   1102                                                 (point)))
   1103     (unless (and (char-after) (memq (char-syntax (char-after)) '(?w ?_)))
   1104       "")))
   1105 
   1106 (defun company-grab-word ()
   1107   "If point is at the end of a word, return it.
   1108 Otherwise, if point is not inside a symbol, return an empty string."
   1109   (if (looking-at "\\>")
   1110       (buffer-substring (point) (save-excursion (skip-syntax-backward "w")
   1111                                                 (point)))
   1112     (unless (and (char-after) (eq (char-syntax (char-after)) ?w))
   1113       "")))
   1114 
   1115 (defun company-grab-symbol-cons (idle-begin-after-re &optional max-len)
   1116   "Return a string SYMBOL or a cons (SYMBOL . t).
   1117 SYMBOL is as returned by `company-grab-symbol'.  If the text before point
   1118 matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons."
   1119   (let ((symbol (company-grab-symbol)))
   1120     (when symbol
   1121       (save-excursion
   1122         (forward-char (- (length symbol)))
   1123         (if (looking-back idle-begin-after-re (if max-len
   1124                                                   (- (point) max-len)
   1125                                                 (line-beginning-position)))
   1126             (cons symbol t)
   1127           symbol)))))
   1128 
   1129 (defun company-in-string-or-comment ()
   1130   "Return non-nil if point is within a string or comment."
   1131   (let ((ppss (syntax-ppss)))
   1132     (or (car (setq ppss (nthcdr 3 ppss)))
   1133         (car (setq ppss (cdr ppss)))
   1134         (nth 3 ppss))))
   1135 
   1136 (defun company-call-backend (&rest args)
   1137   (company--force-sync #'company-call-backend-raw args company-backend))
   1138 
   1139 (defun company--force-sync (fun args backend)
   1140   (let ((value (apply fun args)))
   1141     (if (not (eq (car-safe value) :async))
   1142         value
   1143       (let ((res 'trash)
   1144             (start (time-to-seconds)))
   1145         (funcall (cdr value)
   1146                  (lambda (result) (setq res result)))
   1147         (while (eq res 'trash)
   1148           (if (> (- (time-to-seconds) start) company-async-timeout)
   1149               (error "Company: backend %s async timeout with args %s"
   1150                      backend args)
   1151             ;; XXX: Reusing the trick from company--fetch-candidates here
   1152             ;; doesn't work well: sit-for isn't a good fit when we want to
   1153             ;; ignore pending input (results in too many calls).
   1154             ;; FIXME: We should deal with this by standardizing on a kind of
   1155             ;; Future object that knows how to sync itself. In most cases (but
   1156             ;; not all), by calling accept-process-output, probably.
   1157             (sleep-for company-async-wait)))
   1158         res))))
   1159 
   1160 (defun company-call-backend-raw (&rest args)
   1161   (condition-case-unless-debug err
   1162       (if (functionp company-backend)
   1163           (apply company-backend args)
   1164         (apply #'company--multi-backend-adapter company-backend args))
   1165     (user-error (user-error
   1166                  "Company: backend %s user-error: %s"
   1167                  company-backend (error-message-string err)))
   1168     (error (error "Company: backend %s error \"%s\" with args %s"
   1169                   company-backend (error-message-string err) args))))
   1170 
   1171 (defun company--multi-backend-adapter (backends command &rest args)
   1172   (let ((backends (cl-loop for b in backends
   1173                            when (or (keywordp b)
   1174                                     (company--maybe-init-backend b))
   1175                            collect b))
   1176         (separate (memq :separate backends)))
   1177 
   1178     (when (eq command 'prefix)
   1179       (setq backends (butlast backends (length (member :with backends)))))
   1180 
   1181     (setq backends (cl-delete-if #'keywordp backends))
   1182 
   1183     (pcase command
   1184       (`candidates
   1185        (company--multi-backend-adapter-candidates backends (car args) separate))
   1186       (`sorted separate)
   1187       (`duplicates (not separate))
   1188       ((or `prefix `ignore-case `no-cache `require-match)
   1189        (let (value)
   1190          (cl-dolist (backend backends)
   1191            (when (setq value (company--force-sync
   1192                               backend (cons command args) backend))
   1193              (when (and (eq command 'ignore-case)
   1194                         (eq value 'keep-prefix))
   1195                (setq value t))
   1196              (cl-return value)))))
   1197       (_
   1198        (let ((arg (car args)))
   1199          (when (> (length arg) 0)
   1200            (let ((backend (or (get-text-property 0 'company-backend arg)
   1201                               (car backends))))
   1202              (apply backend command args))))))))
   1203 
   1204 (defun company--multi-backend-adapter-candidates (backends prefix separate)
   1205   (let ((pairs (cl-loop for backend in backends
   1206                         when (equal (company--prefix-str
   1207                                      (let ((company-backend backend))
   1208                                        (company-call-backend 'prefix)))
   1209                                     prefix)
   1210                         collect (cons (funcall backend 'candidates prefix)
   1211                                       (company--multi-candidates-mapper
   1212                                        backend
   1213                                        separate
   1214                                        ;; Small perf optimization: don't tag the
   1215                                        ;; candidates received from the first
   1216                                        ;; backend in the group.
   1217                                        (not (eq backend (car backends))))))))
   1218     (company--merge-async pairs (lambda (values) (apply #'append values)))))
   1219 
   1220 (defun company--multi-candidates-mapper (backend separate tag)
   1221   (lambda (candidates)
   1222     (when separate
   1223       (let ((company-backend backend))
   1224         (setq candidates
   1225               (company--preprocess-candidates candidates))))
   1226     (when tag
   1227       (setq candidates
   1228             (mapcar
   1229              (lambda (str)
   1230                (propertize str 'company-backend backend))
   1231              candidates)))
   1232     candidates))
   1233 
   1234 (defun company--merge-async (pairs merger)
   1235   (let ((async (cl-loop for pair in pairs
   1236                         thereis
   1237                         (eq :async (car-safe (car pair))))))
   1238     (if (not async)
   1239         (funcall merger (cl-loop for (val . mapper) in pairs
   1240                                  collect (funcall mapper val)))
   1241       (cons
   1242        :async
   1243        (lambda (callback)
   1244          (let* (lst
   1245                 (pending (mapcar #'car pairs))
   1246                 (finisher (lambda ()
   1247                             (unless pending
   1248                               (funcall callback
   1249                                        (funcall merger
   1250                                                 (nreverse lst)))))))
   1251            (dolist (pair pairs)
   1252              (push nil lst)
   1253              (let* ((cell lst)
   1254                     (val (car pair))
   1255                     (mapper (cdr pair))
   1256                     (this-finisher (lambda (res)
   1257                                      (setq pending (delq val pending))
   1258                                      (setcar cell (funcall mapper res))
   1259                                      (funcall finisher))))
   1260                (if (not (eq :async (car-safe val)))
   1261                    (funcall this-finisher val)
   1262                  (let ((fetcher (cdr val)))
   1263                    (funcall fetcher this-finisher)))))))))))
   1264 
   1265 (defun company--prefix-str (prefix)
   1266   (or (car-safe prefix) prefix))
   1267 
   1268 ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   1269 
   1270 (defvar-local company-prefix nil)
   1271 
   1272 (defvar-local company-candidates nil)
   1273 
   1274 (defvar-local company-candidates-length nil)
   1275 
   1276 (defvar-local company-candidates-cache nil)
   1277 
   1278 (defvar-local company-candidates-predicate nil)
   1279 
   1280 (defvar-local company-common nil)
   1281 
   1282 (defvar company-selection-default 0
   1283   "The default value for `company-selection'.")
   1284 (defvar-local company-selection company-selection-default)
   1285 
   1286 (defvar-local company-selection-changed nil)
   1287 
   1288 (defvar-local company--manual-action nil
   1289   "Non-nil, if manual completion took place.")
   1290 
   1291 (defvar-local company--manual-prefix nil)
   1292 
   1293 (defvar-local company--point-max nil)
   1294 
   1295 (defvar-local company-point nil)
   1296 
   1297 (defvar company-timer nil)
   1298 (defvar company-tooltip-timer nil)
   1299 
   1300 (defsubst company-strip-prefix (str)
   1301   (substring str (length company-prefix)))
   1302 
   1303 (defun company--insert-candidate (candidate)
   1304   (when (> (length candidate) 0)
   1305     (setq candidate (substring-no-properties candidate))
   1306     ;; XXX: Return value we check here is subject to change.
   1307     (if (eq (company-call-backend 'ignore-case) 'keep-prefix)
   1308         (insert (company-strip-prefix candidate))
   1309       (unless (equal company-prefix candidate)
   1310         (delete-region (- (point) (length company-prefix)) (point))
   1311         (insert candidate)))))
   1312 
   1313 (defmacro company-with-candidate-inserted (candidate &rest body)
   1314   "Evaluate BODY with CANDIDATE temporarily inserted.
   1315 This is a tool for backends that need candidates inserted before they
   1316 can retrieve meta-data for them."
   1317   (declare (indent 1))
   1318   `(let ((inhibit-modification-hooks t)
   1319          (inhibit-point-motion-hooks t)
   1320          (modified-p (buffer-modified-p)))
   1321      (company--insert-candidate ,candidate)
   1322      (unwind-protect
   1323          (progn ,@body)
   1324        (delete-region company-point (point))
   1325        (set-buffer-modified-p modified-p))))
   1326 
   1327 (defun company-explicit-action-p ()
   1328   "Return whether explicit completion action was taken by the user."
   1329   (or company--manual-action
   1330       company-selection-changed))
   1331 
   1332 (defun company-reformat (candidate)
   1333   ;; company-ispell needs this, because the results are always lower-case
   1334   ;; It's mory efficient to fix it only when they are displayed.
   1335   ;; FIXME: Adopt the current text's capitalization instead?
   1336   (if (eq (company-call-backend 'ignore-case) 'keep-prefix)
   1337       (let ((prefix (company--clean-string company-prefix)))
   1338         (concat prefix (substring candidate (length prefix))))
   1339     candidate))
   1340 
   1341 (defun company--should-complete ()
   1342   (and (eq company-idle-delay 'now)
   1343        (not (or buffer-read-only
   1344                 overriding-local-map))
   1345        ;; Check if in the middle of entering a key combination.
   1346        (or (equal (this-command-keys-vector) [])
   1347            (not (keymapp (key-binding (this-command-keys-vector)))))
   1348        (not (and transient-mark-mode mark-active))))
   1349 
   1350 (defun company--should-continue ()
   1351   (or (eq t company-begin-commands)
   1352       (eq t company-continue-commands)
   1353       (if (eq 'not (car company-continue-commands))
   1354           (not (memq this-command (cdr company-continue-commands)))
   1355         (or (memq this-command company-begin-commands)
   1356             (memq this-command company-continue-commands)
   1357             (and (symbolp this-command)
   1358                  (string-match-p "\\`company-" (symbol-name this-command)))))))
   1359 
   1360 (defvar company-auto-update-doc nil
   1361   "If non-nil, update the documentation buffer on each selection change.
   1362 To toggle the value of this variable, call `company-show-doc-buffer' with a
   1363 prefix argument.")
   1364 
   1365 (defun company-call-frontends (command)
   1366   (cl-loop for frontend in company-frontends collect
   1367            (condition-case-unless-debug err
   1368                (funcall frontend command)
   1369              (error (error "Company: frontend %s error \"%s\" on command %s"
   1370                            frontend (error-message-string err) command)))))
   1371 
   1372 (defun company-set-selection (selection &optional force-update)
   1373   "Set SELECTION for company candidates.
   1374 This will update `company-selection' and related variable.
   1375 Only update when the current selection is changed, but optionally always
   1376 update if FORCE-UPDATE."
   1377   (when selection
   1378     (let* ((offset (if company-selection-default 0 1))
   1379            (company-candidates-length
   1380             (+ company-candidates-length offset)))
   1381       (setq selection (+ selection offset))
   1382       (setq selection
   1383             (if company-selection-wrap-around
   1384                 (mod selection company-candidates-length)
   1385               (max 0 (min (1- company-candidates-length) selection))))
   1386       (setq selection (unless (< selection offset)
   1387                         (- selection offset)))))
   1388   (when (or force-update (not (equal selection company-selection)))
   1389     (setq company-selection selection
   1390           company-selection-changed t)
   1391     (company-call-frontends 'update)))
   1392 
   1393 (defun company--group-lighter (candidate base)
   1394   (let ((backend (or (get-text-property 0 'company-backend candidate)
   1395                      (cl-some (lambda (x) (and (not (keywordp x)) x))
   1396                               company-backend))))
   1397     (when (and backend (symbolp backend))
   1398       (let ((name (replace-regexp-in-string "company-\\|-company" ""
   1399                                             (symbol-name backend))))
   1400         (format "%s-<%s>" base name)))))
   1401 
   1402 (defun company-update-candidates (candidates)
   1403   (setq company-candidates-length (length candidates))
   1404   (if company-selection-changed
   1405       ;; Try to restore the selection
   1406       (let ((selected (and company-selection
   1407                            (nth company-selection company-candidates))))
   1408         (setq company-candidates candidates)
   1409         (when selected
   1410           (setq company-selection 0)
   1411           (catch 'found
   1412             (while candidates
   1413               (let ((candidate (pop candidates)))
   1414                 (when (and (string= candidate selected)
   1415                            (equal (company-call-backend 'annotation candidate)
   1416                                   (company-call-backend 'annotation selected)))
   1417                   (throw 'found t)))
   1418               (cl-incf company-selection))
   1419             (setq company-selection company-selection-default
   1420                   company-selection-changed nil))))
   1421     (setq company-selection company-selection-default
   1422           company-candidates candidates))
   1423   ;; Calculate common.
   1424   (let ((completion-ignore-case (company-call-backend 'ignore-case)))
   1425     ;; We want to support non-prefix completion, so filtering is the
   1426     ;; responsibility of each respective backend, not ours.
   1427     ;; On the other hand, we don't want to replace non-prefix input in
   1428     ;; `company-complete-common', unless there's only one candidate.
   1429     (setq company-common
   1430           (if (cdr company-candidates)
   1431               (let ((common (try-completion "" company-candidates)))
   1432                 (when (string-prefix-p company-prefix common
   1433                                        completion-ignore-case)
   1434                   common))
   1435             (car company-candidates)))))
   1436 
   1437 (defun company-calculate-candidates (prefix ignore-case)
   1438   (let ((candidates (cdr (assoc prefix company-candidates-cache))))
   1439     (or candidates
   1440         (when company-candidates-cache
   1441           (let ((len (length prefix))
   1442                 (completion-ignore-case ignore-case)
   1443                 prev)
   1444             (cl-dotimes (i (1+ len))
   1445               (when (setq prev (cdr (assoc (substring prefix 0 (- len i))
   1446                                            company-candidates-cache)))
   1447                 (setq candidates (all-completions prefix prev))
   1448                 (cl-return t)))))
   1449         ;; No cache match, call the backend.
   1450         (let ((refresh-timer (run-with-timer company-async-redisplay-delay
   1451                                              nil #'company--sneaky-refresh)))
   1452           (setq candidates (company--preprocess-candidates
   1453                             (company--fetch-candidates prefix)))
   1454           ;; If the backend is synchronous, no chance for the timer to run.
   1455           (cancel-timer refresh-timer)
   1456           ;; Save in cache.
   1457           (push (cons prefix candidates) company-candidates-cache)))
   1458     ;; Only now apply the predicate and transformers.
   1459     (company--postprocess-candidates candidates)))
   1460 
   1461 (defun company--unique-match-p (candidates prefix ignore-case)
   1462   (and candidates
   1463        (not (cdr candidates))
   1464        (eq t (compare-strings (car candidates) nil nil
   1465                               prefix nil nil ignore-case))
   1466        (not (eq (company-call-backend 'kind (car candidates))
   1467                 'snippet))))
   1468 
   1469 (defun company--fetch-candidates (prefix)
   1470   (let* ((non-essential (not (company-explicit-action-p)))
   1471          (inhibit-redisplay t)
   1472          (c (if (or company-selection-changed
   1473                     ;; FIXME: This is not ideal, but we have not managed to deal
   1474                     ;; with these situations in a better way yet.
   1475                     (company-require-match-p))
   1476                 (company-call-backend 'candidates prefix)
   1477               (company-call-backend-raw 'candidates prefix))))
   1478     (if (not (eq (car c) :async))
   1479         c
   1480       (let ((res 'none))
   1481         (funcall
   1482          (cdr c)
   1483          (lambda (candidates)
   1484            (when (eq res 'none)
   1485              (push 'company-foo unread-command-events))
   1486            (setq res candidates)))
   1487         (if (company--flyspell-workaround-p)
   1488             (while (and (eq res 'none)
   1489                         (not (input-pending-p)))
   1490               (sleep-for company-async-wait))
   1491           (while (and (eq res 'none)
   1492                       (sit-for 0.5 t))))
   1493         (while (member (car unread-command-events)
   1494                        '(company-foo (t . company-foo)))
   1495           (pop unread-command-events))
   1496         (prog1
   1497             (and (consp res) res)
   1498           (setq res 'exited))))))
   1499 
   1500 (defun company--sneaky-refresh ()
   1501   (when company-candidates (company-call-frontends 'unhide))
   1502   (let (inhibit-redisplay)
   1503     (redisplay))
   1504   (when company-candidates (company-call-frontends 'pre-command)))
   1505 
   1506 (defun company--flyspell-workaround-p ()
   1507   ;; https://debbugs.gnu.org/23980
   1508   (and (bound-and-true-p flyspell-mode)
   1509        (version< emacs-version "27")))
   1510 
   1511 (defun company--preprocess-candidates (candidates)
   1512   (cl-assert (cl-every #'stringp candidates))
   1513   (unless (company-call-backend 'sorted)
   1514     (setq candidates (sort candidates 'string<)))
   1515   (when (company-call-backend 'duplicates)
   1516     (company--strip-duplicates candidates))
   1517   candidates)
   1518 
   1519 (defun company--postprocess-candidates (candidates)
   1520   (when (or company-candidates-predicate company-transformers)
   1521     (setq candidates (copy-sequence candidates)))
   1522   (when company-candidates-predicate
   1523     (setq candidates (cl-delete-if-not company-candidates-predicate candidates)))
   1524   (company--transform-candidates candidates))
   1525 
   1526 (defun company--strip-duplicates (candidates)
   1527   (let ((c2 candidates)
   1528         (extras 'unk))
   1529     (while c2
   1530       (setcdr c2
   1531               (let ((str (pop c2)))
   1532                 (while (let ((str2 (car c2)))
   1533                          (if (not (equal str str2))
   1534                              (progn
   1535                                (setq extras 'unk)
   1536                                nil)
   1537                            (when (eq extras 'unk)
   1538                              (setq extras (list (cons (company-call-backend
   1539                                                        'annotation str)
   1540                                                       (company-call-backend
   1541                                                        'kind str)))))
   1542                            (let ((extra2 (cons (company-call-backend
   1543                                                 'annotation str2)
   1544                                                (company-call-backend
   1545                                                 'kind str2))))
   1546                              (if (member extra2 extras)
   1547                                  t
   1548                                (push extra2 extras)
   1549                                nil))))
   1550                   (pop c2))
   1551                 c2)))))
   1552 
   1553 (defun company--transform-candidates (candidates)
   1554   (let ((c candidates))
   1555     (dolist (tr company-transformers)
   1556       (setq c (funcall tr c)))
   1557     c))
   1558 
   1559 (defcustom company-occurrence-weight-function
   1560   #'company-occurrence-prefer-closest-above
   1561   "Function to weigh matches in `company-sort-by-occurrence'.
   1562 It's called with three arguments: cursor position, the beginning and the
   1563 end of the match."
   1564   :type '(choice
   1565           (const :tag "First above point, then below point"
   1566                  company-occurrence-prefer-closest-above)
   1567           (const :tag "Prefer closest in any direction"
   1568                  company-occurrence-prefer-any-closest)))
   1569 
   1570 (defvar company-vscode-icons-mapping
   1571   '((array . "symbol-array.svg")
   1572     (boolean . "symbol-boolean.svg")
   1573     (class . "symbol-class.svg")
   1574     (color . "symbol-color.svg")
   1575     (constant . "symbol-constant.svg")
   1576     (constructor . "symbol-method.svg")
   1577     (enum-member . "symbol-enumerator-member.svg")
   1578     (enum . "symbol-enumerator.svg")
   1579     (event . "symbol-event.svg")
   1580     (field . "symbol-field.svg")
   1581     (file . "symbol-file.svg")
   1582     (folder . "folder.svg")
   1583     (interface . "symbol-interface.svg")
   1584     (keyword . "symbol-keyword.svg")
   1585     (method . "symbol-method.svg")
   1586     (function . "symbol-method.svg")
   1587     (module . "symbol-namespace.svg")
   1588     (numeric . "symbol-numeric.svg")
   1589     (operator . "symbol-operator.svg")
   1590     (property . "symbol-property.svg")
   1591     (reference . "references.svg")
   1592     (snippet . "symbol-snippet.svg")
   1593     (string . "symbol-string.svg")
   1594     (struct . "symbol-structure.svg")
   1595     (text . "symbol-key.svg")
   1596     (type-parameter . "symbol-parameter.svg")
   1597     (unit . "symbol-ruler.svg")
   1598     (value . "symbol-enumerator.svg")
   1599     (variable . "symbol-variable.svg")
   1600     (t . "symbol-misc.svg")))
   1601 
   1602 (defconst company-icons-root
   1603   (file-name-as-directory
   1604    (expand-file-name "icons"
   1605                      (file-name-directory (or load-file-name buffer-file-name)))))
   1606 
   1607 (defcustom company-icon-size '(auto-scale . 16)
   1608   "Size of icons indicating completion kind in the popup."
   1609   :type '(choice (integer :tag "Size in pixels" :value 16)
   1610                  (cons :tag "Size in pixels, scaled 2x on HiDPI screens"
   1611                        (const auto-scale)
   1612                        (integer :value 16))))
   1613 
   1614 (defcustom company-icon-margin 2
   1615   "Width of the margin that shows the icons, in characters."
   1616   :type 'integer)
   1617 
   1618 (defun company--render-icons-margin (icon-mapping root-dir candidate selected)
   1619   (if-let ((ws (window-system))
   1620            (candidate candidate)
   1621            (kind (company-call-backend 'kind candidate))
   1622            (icon-file (or (alist-get kind icon-mapping)
   1623                           (alist-get t icon-mapping))))
   1624       (let* ((bkg (face-attribute (if selected
   1625                                       'company-tooltip-selection
   1626                                     'company-tooltip)
   1627                                   :background))
   1628              (dfw (default-font-width))
   1629              (icon-size (cond
   1630                          ((integerp company-icon-size)
   1631                           company-icon-size)
   1632                          ;; XXX: Also consider smooth scaling, e.g. using
   1633                          ;; (aref (font-info (face-font 'default)) 2)
   1634                          ((and (consp company-icon-size)
   1635                                (eq 'auto-scale (car company-icon-size)))
   1636                           (let ((base-size (cdr company-icon-size))
   1637                                 (dfh (default-font-height)))
   1638                             (min
   1639                              (if (>= dfh (* 2 base-size))
   1640                                  (* 2 base-size)
   1641                                base-size)
   1642                              (* company-icon-margin dfw))))))
   1643              (spec (list 'image
   1644                          :file (expand-file-name icon-file root-dir)
   1645                          :type 'svg
   1646                          :width icon-size
   1647                          :height icon-size
   1648                          :ascent 'center
   1649                          :background (unless (eq bkg 'unspecified)
   1650                                        bkg)))
   1651              (spacer-px-width (- (* company-icon-margin dfw) icon-size)))
   1652         (cond
   1653          ((<= company-icon-margin 2)
   1654           (concat
   1655            (propertize " " 'display spec)
   1656            (propertize (company-space-string (1- company-icon-margin))
   1657                        'display `(space . (:width (,spacer-px-width))))))
   1658          (t
   1659           (let* ((spacer-left (/ spacer-px-width 2))
   1660                  (spacer-right (- spacer-px-width spacer-left)))
   1661             (concat
   1662              (propertize (company-space-string 1)
   1663                          'display `(space . (:width (,spacer-left))))
   1664              (propertize " " 'display spec)
   1665              (propertize (company-space-string (- company-icon-margin 2))
   1666                          'display `(space . (:width (,spacer-right)))))))))
   1667     nil))
   1668 
   1669 (defun company-vscode-dark-icons-margin (candidate selected)
   1670   "Margin function which returns icons from vscode's dark theme."
   1671   (company--render-icons-margin company-vscode-icons-mapping
   1672                                 (expand-file-name "vscode-dark" company-icons-root)
   1673                                 candidate
   1674                                 selected))
   1675 
   1676 (defun company-vscode-light-icons-margin (candidate selected)
   1677   "Margin function which returns icons from vscode's light theme."
   1678   (company--render-icons-margin company-vscode-icons-mapping
   1679                                 (expand-file-name "vscode-light" company-icons-root)
   1680                                 candidate
   1681                                 selected))
   1682 
   1683 (defcustom company-text-icons-mapping
   1684   '((array "a" font-lock-type-face)
   1685     (boolean "b" font-lock-builtin-face)
   1686     (class "c" font-lock-type-face)
   1687     (color "#" success)
   1688     (constant "c" font-lock-constant-face)
   1689     (constructor "c" font-lock-function-name-face)
   1690     (enum-member "e" font-lock-builtin-face)
   1691     (enum "e" font-lock-builtin-face)
   1692     (field "f" font-lock-variable-name-face)
   1693     (file "f" font-lock-string-face)
   1694     (folder "d" font-lock-doc-face)
   1695     (interface "i" font-lock-type-face)
   1696     (keyword "k" font-lock-keyword-face)
   1697     (method "m" font-lock-function-name-face)
   1698     (function "f" font-lock-function-name-face)
   1699     (module "{" font-lock-type-face)
   1700     (numeric "n" font-lock-builtin-face)
   1701     (operator "o" font-lock-comment-delimiter-face)
   1702     (property "p" font-lock-variable-name-face)
   1703     (reference "r" font-lock-doc-face)
   1704     (snippet "S" font-lock-string-face)
   1705     (string "s" font-lock-string-face)
   1706     (struct "%" font-lock-variable-name-face)
   1707     (text "w" shadow)
   1708     (type-parameter "p" font-lock-type-face)
   1709     (unit "u" shadow)
   1710     (value "v" font-lock-builtin-face)
   1711     (variable "v" font-lock-variable-name-face)
   1712     (t "." shadow))
   1713   "Mapping of the text icons.
   1714 The format should be an alist of (KIND . CONF) where CONF is a list of the
   1715 form (ICON FG BG) which is used to propertize the icon to be shown for a
   1716 candidate of kind KIND. FG can either be color string or a face from which
   1717 we can get a color string (using the :foreground face-property). BG must be
   1718 of the same form as FG or a cons cell of (BG . BG-WHEN-SELECTED) which each
   1719 should be of the same form as FG.
   1720 
   1721 The only mandatory element in CONF is ICON, you can omit both the FG and BG
   1722 fields without issue.
   1723 
   1724 When BG is omitted and `company-text-icons-add-background' is non-nil, a BG
   1725 color is generated using a gradient between the active tooltip color and
   1726 the FG color."
   1727   :type '(repeat sexp))
   1728 
   1729 (defcustom company-text-face-extra-attributes '(:weight bold)
   1730   "Additional attributes to add to text/dot icons faces.
   1731 If non-nil, an anonymous face is generated.
   1732 
   1733 Affects `company-text-icons-margin' and `company-dot-icons-margin'."
   1734   :type '(plist :tag "Face property list"))
   1735 
   1736 (defcustom company-text-icons-format " %s "
   1737   "Format string for printing the text icons."
   1738   :type 'string)
   1739 
   1740 (defcustom company-text-icons-add-background nil
   1741   "Generate a background color for text/dot icons when none is given.
   1742 See `company-text-icons-mapping'."
   1743   :type 'boolean)
   1744 
   1745 (defun company-text-icons-margin (candidate selected)
   1746   "Margin function which returns unicode icons."
   1747   (when-let ((candidate candidate)
   1748              (kind (company-call-backend 'kind candidate))
   1749              (conf (or (alist-get kind company-text-icons-mapping)
   1750                        (alist-get t company-text-icons-mapping))))
   1751     (cl-destructuring-bind (icon &optional fg bg) conf
   1752       (propertize
   1753        (format company-text-icons-format icon)
   1754        'face
   1755        (company-text-icons--face fg bg selected)))))
   1756 
   1757 (declare-function color-rgb-to-hex "color")
   1758 (declare-function color-gradient "color")
   1759 
   1760 (defun company-text-icons--extract-property (face property)
   1761   "Try to extract PROPERTY from FACE.
   1762 If FACE isn't a valid face return FACE as is. If FACE doesn't have
   1763 PROPERTY return nil."
   1764   (if (facep face)
   1765       (let ((value (face-attribute face property)))
   1766         (unless (eq value 'unspecified)
   1767           value))
   1768     face))
   1769 
   1770 (defun company-text-icons--face (fg bg selected)
   1771   (let ((fg-color (company-text-icons--extract-property fg :foreground)))
   1772     `(,@company-text-face-extra-attributes
   1773       ,@(and fg-color
   1774              (list :foreground fg-color))
   1775       ,@(let* ((bg-is-cons (consp bg))
   1776                (bg (if bg-is-cons (if selected (cdr bg) (car bg)) bg))
   1777                (bg-color (company-text-icons--extract-property bg :background))
   1778                (tooltip-bg-color (company-text-icons--extract-property
   1779                                   (if selected
   1780                                       'company-tooltip-selection
   1781                                     'company-tooltip)
   1782                                   :background)))
   1783           (cond
   1784            ((and company-text-icons-add-background selected
   1785                  (not bg-is-cons) bg-color tooltip-bg-color)
   1786             ;; Adjust the coloring of the background when *selected* but user hasn't
   1787             ;; specified an alternate background color for selected item icons.
   1788             (list :background
   1789                   (apply #'color-rgb-to-hex
   1790                          (nth 0 (color-gradient (color-name-to-rgb tooltip-bg-color)
   1791                                                 (color-name-to-rgb bg-color)
   1792                                                 2)))))
   1793            (bg
   1794             ;; When background is configured we use it as is, even if it doesn't
   1795             ;; constrast well with other candidates when selected.
   1796             (and bg-color
   1797                  (list :background bg-color)))
   1798            ((and company-text-icons-add-background fg-color tooltip-bg-color)
   1799             ;; Lastly attempt to generate a background from the foreground.
   1800             (list :background
   1801                   (apply #'color-rgb-to-hex
   1802                          (nth 0 (color-gradient (color-name-to-rgb tooltip-bg-color)
   1803                                                 (color-name-to-rgb fg-color)
   1804                                                 10))))))))))
   1805 
   1806 (defcustom company-dot-icons-format "● "
   1807   "Format string for `company-dot-icons-margin'."
   1808   :type 'string)
   1809 
   1810 (defun company-dot-icons-margin (candidate selected)
   1811   "Margin function that uses a colored dot to display completion kind."
   1812   (when-let ((kind (company-call-backend 'kind candidate))
   1813              (conf (or (assoc-default kind company-text-icons-mapping)
   1814                        (assoc-default t company-text-icons-mapping))))
   1815     (cl-destructuring-bind (_icon &optional fg bg) conf
   1816       (propertize company-dot-icons-format
   1817                   'face
   1818                   (company-text-icons--face fg bg selected)))))
   1819 
   1820 (defun company-detect-icons-margin (candidate selected)
   1821   "Margin function which picks the appropriate icon set automatically."
   1822   (if (and (display-graphic-p)
   1823            (image-type-available-p 'svg))
   1824       (cl-case (frame-parameter nil 'background-mode)
   1825         (light (company-vscode-light-icons-margin candidate selected))
   1826         (t (company-vscode-dark-icons-margin candidate selected)))
   1827     (company-text-icons-margin candidate selected)))
   1828 
   1829 (defcustom company-format-margin-function #'company-detect-icons-margin
   1830   "Function to format the margin.
   1831 It accepts 2 params `candidate' and `selected' and can be used for
   1832 inserting prefix/image before the completion items. Typically, the
   1833 functions call the backends with `kind' and then insert the appropriate
   1834 image for the returned kind image. Function is called with (nil nil) to get
   1835 the default margin."
   1836   :type '(choice
   1837           (const :tag "Disabled" nil)
   1838           (const :tag "Detect icons theme base on conditions" company-detect-icons-margin)
   1839           (const :tag "Text characters as icons" company-text-icons-margin)
   1840           (const :tag "Colored dots as icons" company-dot-icons-margin)
   1841           (const :tag "VScode dark icons theme" company-vscode-dark-icons-margin)
   1842           (const :tag "VScode light icons theme" company-vscode-light-icons-margin)
   1843           (function :tag "Custom icon function.")))
   1844 
   1845 (defun company-occurrence-prefer-closest-above (pos match-beg match-end)
   1846   "Give priority to the matches above point, then those below point."
   1847   (if (< match-beg pos)
   1848       (- pos match-end)
   1849     (- match-beg (window-start))))
   1850 
   1851 (defun company-occurrence-prefer-any-closest (pos _match-beg match-end)
   1852   "Give priority to the matches closest to the point."
   1853   (abs (- pos match-end)))
   1854 
   1855 (defun company-sort-by-occurrence (candidates)
   1856   "Sort CANDIDATES according to their occurrences.
   1857 Searches for each in the currently visible part of the current buffer and
   1858 prioritizes the matches according to `company-occurrence-weight-function'.
   1859 The rest of the list is appended unchanged.
   1860 Keywords and function definition names are ignored."
   1861   (let* ((w-start (window-start))
   1862          (w-end (window-end))
   1863          (start-point (point))
   1864          occurs
   1865          (noccurs
   1866           (save-excursion
   1867             (cl-delete-if
   1868              (lambda (candidate)
   1869                (goto-char w-start)
   1870                (when (and (not (equal candidate ""))
   1871                           (search-forward candidate w-end t)
   1872                           ;; ^^^ optimize for large lists where most elements
   1873                           ;; won't have a match.
   1874                           (catch 'done
   1875                             (goto-char (1- start-point))
   1876                             (while (search-backward candidate w-start t)
   1877                               (when (save-match-data
   1878                                       (company--occurrence-predicate))
   1879                                 (throw 'done t)))
   1880                             (goto-char start-point)
   1881                             (while (search-forward candidate w-end t)
   1882                               (when (save-match-data
   1883                                       (company--occurrence-predicate))
   1884                                 (throw 'done t)))))
   1885                  (push
   1886                   (cons candidate
   1887                         (funcall company-occurrence-weight-function
   1888                                  start-point
   1889                                  (match-beginning 0)
   1890                                  (match-end 0)))
   1891                   occurs)
   1892                  t))
   1893              candidates))))
   1894     (nconc
   1895      (mapcar #'car (sort occurs (lambda (e1 e2) (<= (cdr e1) (cdr e2)))))
   1896      noccurs)))
   1897 
   1898 (defun company--occurrence-predicate ()
   1899   (defvar comint-last-prompt)
   1900   (let ((beg (match-beginning 0))
   1901         (end (match-end 0))
   1902         (comint-last-prompt (bound-and-true-p comint-last-prompt)))
   1903     (save-excursion
   1904       (goto-char end)
   1905       ;; Workaround for python-shell-completion-at-point's behavior:
   1906       ;; https://github.com/company-mode/company-mode/issues/759
   1907       ;; https://github.com/company-mode/company-mode/issues/549
   1908       (when (derived-mode-p 'inferior-python-mode)
   1909         (let ((lbp (line-beginning-position)))
   1910           (setq comint-last-prompt (cons lbp lbp))))
   1911       (and (not (memq (get-text-property (1- (point)) 'face)
   1912                       '(font-lock-function-name-face
   1913                         font-lock-keyword-face)))
   1914            (let ((prefix (company--prefix-str
   1915                           (company-call-backend 'prefix))))
   1916              (and (stringp prefix)
   1917                   (= (length prefix) (- end beg))))))))
   1918 
   1919 (defun company-sort-by-backend-importance (candidates)
   1920   "Sort CANDIDATES as two priority groups.
   1921 If `company-backend' is a function, do nothing.  If it's a list, move
   1922 candidates from backends before keyword `:with' to the front.  Candidates
   1923 from the rest of the backends in the group, if any, will be left at the end."
   1924   (if (functionp company-backend)
   1925       candidates
   1926     (let ((low-priority (cdr (memq :with company-backend))))
   1927       (if (null low-priority)
   1928           candidates
   1929         (sort candidates
   1930               (lambda (c1 c2)
   1931                 (and
   1932                  (let ((b2 (get-text-property 0 'company-backend c2)))
   1933                    (and b2 (memq b2 low-priority)))
   1934                  (let ((b1 (get-text-property 0 'company-backend c1)))
   1935                    (or (not b1) (not (memq b1 low-priority)))))))))))
   1936 
   1937 (defun company-sort-prefer-same-case-prefix (candidates)
   1938   "Prefer CANDIDATES with the exact same prefix.
   1939 If a backend returns case insensitive matches, candidates with the an exact
   1940 prefix match (same case) will be prioritized."
   1941   (cl-loop for candidate in candidates
   1942            if (string-prefix-p company-prefix candidate)
   1943            collect candidate into same-case
   1944            else collect candidate into other-case
   1945            finally return (append same-case other-case)))
   1946 
   1947 (defun company-idle-begin (buf win tick pos)
   1948   (and (eq buf (current-buffer))
   1949        (eq win (selected-window))
   1950        (eq tick (buffer-chars-modified-tick))
   1951        (eq pos (point))
   1952        (let ((non-essential t))
   1953          (when (company-auto-begin)
   1954            (let ((this-command 'company-idle-begin))
   1955              (company-post-command))))))
   1956 
   1957 (defun company-auto-begin ()
   1958   (and company-mode
   1959        (not company-candidates)
   1960        (let ((company-idle-delay 'now))
   1961          (condition-case-unless-debug err
   1962              (let ((inhibit-quit nil))
   1963                (company--perform)
   1964                ;; Return non-nil if active.
   1965                company-candidates)
   1966            (error (message "Company: An error occurred in auto-begin")
   1967                   (message "%s" (error-message-string err))
   1968                   (company-cancel))
   1969            (quit (company-cancel))))))
   1970 
   1971 ;;;###autoload
   1972 (defun company-manual-begin ()
   1973   (interactive)
   1974   (company-assert-enabled)
   1975   (setq company--manual-action t)
   1976   (unwind-protect
   1977       (let ((company-minimum-prefix-length 0))
   1978         (or company-candidates
   1979             (company-auto-begin)))
   1980     (unless company-candidates
   1981       (setq company--manual-action nil))))
   1982 
   1983 (defun company-other-backend (&optional backward)
   1984   (interactive (list current-prefix-arg))
   1985   (company-assert-enabled)
   1986   (let* ((after (if company-backend
   1987                     (cdr (member company-backend company-backends))
   1988                   company-backends))
   1989          (before (cdr (member company-backend (reverse company-backends))))
   1990          (next (if backward
   1991                    (append before (reverse after))
   1992                  (append after (reverse before)))))
   1993     (company-cancel)
   1994     (cl-dolist (backend next)
   1995       (when (ignore-errors (company-begin-backend backend))
   1996         (cl-return t))))
   1997   (unless company-candidates
   1998     (user-error "No other backend")))
   1999 
   2000 (defun company-require-match-p ()
   2001   (let ((backend-value (company-call-backend 'require-match)))
   2002     (or (eq backend-value t)
   2003         (and (not (eq backend-value 'never))
   2004              (if (functionp company-require-match)
   2005                  (funcall company-require-match)
   2006                (eq company-require-match t))))))
   2007 
   2008 (defun company-insertion-on-trigger-p (input)
   2009   "Return non-nil if INPUT should trigger insertion.
   2010 For more details see `company-insertion-on-trigger' and
   2011 `company-insertion-triggers'."
   2012   (and (if (functionp company-insertion-on-trigger)
   2013            (funcall company-insertion-on-trigger)
   2014          company-insertion-on-trigger)
   2015        (if (functionp company-insertion-triggers)
   2016            (funcall company-insertion-triggers input)
   2017          (if (consp company-insertion-triggers)
   2018              (memq (char-syntax (string-to-char input))
   2019                    company-insertion-triggers)
   2020            (string-match (regexp-quote (substring input 0 1))
   2021                          company-insertion-triggers)))))
   2022 
   2023 (defun company--incremental-p ()
   2024   (and (> (point) company-point)
   2025        (> (point-max) company--point-max)
   2026        (not (eq this-command 'backward-delete-char-untabify))
   2027        (equal (buffer-substring (- company-point (length company-prefix))
   2028                                 company-point)
   2029               company-prefix)))
   2030 
   2031 (defun company--continue-failed (new-prefix)
   2032   (cond
   2033    ((and (or (not (company-require-match-p))
   2034              ;; Don't require match if the new prefix
   2035              ;; doesn't continue the old one, and the latter was a match.
   2036              (not (stringp new-prefix))
   2037              (<= (length new-prefix) (length company-prefix)))
   2038          (member company-prefix company-candidates))
   2039     ;; Last input was a success,
   2040     ;; but we're treating it as an abort + input anyway,
   2041     ;; like the `unique' case below.
   2042     (company-cancel 'non-unique))
   2043    ((company-require-match-p)
   2044     ;; Wrong incremental input, but required match.
   2045     (delete-char (- company-point (point)))
   2046     (ding)
   2047     (message "Matching input is required")
   2048     company-candidates)
   2049    (t (company-cancel))))
   2050 
   2051 (defun company--good-prefix-p (prefix)
   2052   (and (stringp (company--prefix-str prefix)) ;excludes 'stop
   2053        (or (eq (cdr-safe prefix) t)
   2054            (let ((len (or (cdr-safe prefix) (length prefix))))
   2055              (if company--manual-prefix
   2056                  (or (not company-abort-manual-when-too-short)
   2057                      ;; Must not be less than minimum or initial length.
   2058                      (>= len (min company-minimum-prefix-length
   2059                                   (length company--manual-prefix))))
   2060                (>= len company-minimum-prefix-length))))))
   2061 
   2062 (defun company--continue ()
   2063   (when (company-call-backend 'no-cache company-prefix)
   2064     ;; Don't complete existing candidates, fetch new ones.
   2065     (setq company-candidates-cache nil))
   2066   (let* ((new-prefix (company-call-backend 'prefix))
   2067          (ignore-case (company-call-backend 'ignore-case))
   2068          (c (when (and (company--good-prefix-p new-prefix)
   2069                        (setq new-prefix (company--prefix-str new-prefix))
   2070                        (= (- (point) (length new-prefix))
   2071                           (- company-point (length company-prefix))))
   2072               (company-calculate-candidates new-prefix ignore-case))))
   2073     (cond
   2074      ((and company-abort-on-unique-match
   2075            (company--unique-match-p c new-prefix ignore-case))
   2076       ;; Handle it like completion was aborted, to differentiate from user
   2077       ;; calling one of Company's commands to insert the candidate,
   2078       ;; not to trigger template expansion, etc.
   2079       (company-cancel 'unique))
   2080      ((consp c)
   2081       ;; incremental match
   2082       (setq company-prefix new-prefix)
   2083       (company-update-candidates c)
   2084       c)
   2085      ((and (characterp last-command-event)
   2086            (company-insertion-on-trigger-p (string last-command-event)))
   2087       ;; Insertion on trigger.
   2088       (save-excursion
   2089         (goto-char company-point)
   2090         (company-complete-selection)
   2091         nil))
   2092      ((not (company--incremental-p))
   2093       (company-cancel))
   2094      (t (company--continue-failed new-prefix)))))
   2095 
   2096 (defun company--begin-new ()
   2097   (let (prefix c)
   2098     (cl-dolist (backend (if company-backend
   2099                             ;; prefer manual override
   2100                             (list company-backend)
   2101                           company-backends))
   2102       (setq prefix
   2103             (if (or (symbolp backend)
   2104                     (functionp backend))
   2105                 (when (company--maybe-init-backend backend)
   2106                   (let ((company-backend backend))
   2107                     (company-call-backend 'prefix)))
   2108               (company--multi-backend-adapter backend 'prefix)))
   2109       (when prefix
   2110         (when (company--good-prefix-p prefix)
   2111           (let ((ignore-case (company-call-backend 'ignore-case)))
   2112             (setq company-prefix (company--prefix-str prefix)
   2113                   company-backend backend
   2114                   c (company-calculate-candidates company-prefix ignore-case))
   2115             (cond
   2116              ((and company-abort-on-unique-match
   2117                    (company--unique-match-p c company-prefix ignore-case)
   2118                    (if company--manual-action
   2119                        ;; If `company-manual-begin' was called, the user
   2120                        ;; really wants something to happen.  Otherwise...
   2121                        (ignore (message "Sole completion"))
   2122                      t))
   2123               ;; ...abort and run the hooks, e.g. to clear the cache.
   2124               (company-cancel 'unique))
   2125              ((null c)
   2126               (when company--manual-action
   2127                 (message "No completion found")))
   2128              (t ;; We got completions!
   2129               (when company--manual-action
   2130                 (setq company--manual-prefix prefix))
   2131               (company-update-candidates c)
   2132               (run-hook-with-args 'company-completion-started-hook
   2133                                   (company-explicit-action-p))
   2134               (company-call-frontends 'show)))))
   2135         (cl-return c)))))
   2136 
   2137 (defun company--perform ()
   2138   (cond
   2139    (company-candidates
   2140     (company--continue))
   2141    ((company--should-complete)
   2142     (company--begin-new)))
   2143   (if (not company-candidates)
   2144       (setq company-backend nil)
   2145     (setq company-point (point)
   2146           company--point-max (point-max))
   2147     (company-ensure-emulation-alist)
   2148     (company-enable-overriding-keymap company-active-map)
   2149     (company-call-frontends 'update)))
   2150 
   2151 (defun company-cancel (&optional result)
   2152   (let ((prefix company-prefix)
   2153         (backend company-backend))
   2154     (setq company-backend nil
   2155           company-prefix nil
   2156           company-candidates nil
   2157           company-candidates-length nil
   2158           company-candidates-cache nil
   2159           company-candidates-predicate nil
   2160           company-common nil
   2161           company-selection company-selection-default
   2162           company-selection-changed nil
   2163           company--manual-action nil
   2164           company--manual-prefix nil
   2165           company--point-max nil
   2166           company-point nil)
   2167     (when company-timer
   2168       (cancel-timer company-timer))
   2169     (company-echo-cancel t)
   2170     (company-search-mode 0)
   2171     (company-call-frontends 'hide)
   2172     (company-enable-overriding-keymap nil)
   2173     (when prefix
   2174       (if (stringp result)
   2175           (let ((company-backend backend))
   2176             (run-hook-with-args 'company-completion-finished-hook result)
   2177             (company-call-backend 'post-completion result))
   2178         (run-hook-with-args 'company-completion-cancelled-hook result))
   2179       (run-hook-with-args 'company-after-completion-hook result)))
   2180   ;; Make return value explicit.
   2181   nil)
   2182 
   2183 (defun company-abort ()
   2184   (interactive)
   2185   (company-cancel 'abort))
   2186 
   2187 (defun company-finish (result)
   2188   (company--insert-candidate result)
   2189   (company-cancel result))
   2190 
   2191 (defsubst company-keep (command)
   2192   (and (symbolp command) (get command 'company-keep)))
   2193 
   2194 (defun company--active-p ()
   2195   company-candidates)
   2196 
   2197 (defun company-pre-command ()
   2198   (company--electric-restore-window-configuration)
   2199   (unless (company-keep this-command)
   2200     (condition-case-unless-debug err
   2201         (when company-candidates
   2202           (company-call-frontends 'pre-command)
   2203           (unless (company--should-continue)
   2204             (company-abort)))
   2205       (error (message "Company: An error occurred in pre-command")
   2206              (message "%s" (error-message-string err))
   2207              (company-cancel))))
   2208   (when company-timer
   2209     (cancel-timer company-timer)
   2210     (setq company-timer nil))
   2211   (company-echo-cancel t)
   2212   (company-uninstall-map))
   2213 
   2214 (defun company-post-command ()
   2215   (when (and company-candidates
   2216              (null this-command))
   2217     ;; Happens when the user presses `C-g' while inside
   2218     ;; `flyspell-post-command-hook', for example.
   2219     ;; Or any other `post-command-hook' function that can call `sit-for',
   2220     ;; or any quittable timer function.
   2221     (company-abort)
   2222     (setq this-command 'company-abort))
   2223   (unless (company-keep this-command)
   2224     (condition-case-unless-debug err
   2225         (progn
   2226           (unless (equal (point) company-point)
   2227             (let (company-idle-delay) ; Against misbehavior while debugging.
   2228               (company--perform)))
   2229           (if company-candidates
   2230               (progn
   2231                 (company-call-frontends 'post-command)
   2232                 (when company-auto-update-doc
   2233                   (condition-case nil
   2234                       (unless (company--electric-command-p)
   2235                         (company-show-doc-buffer))
   2236                     (user-error nil)
   2237                     (quit nil))))
   2238             (let ((delay (company--idle-delay)))
   2239              (and (numberp delay)
   2240                   (not defining-kbd-macro)
   2241                   (company--should-begin)
   2242                   (setq company-timer
   2243                         (run-with-timer delay nil
   2244                                         'company-idle-begin
   2245                                         (current-buffer) (selected-window)
   2246                                         (buffer-chars-modified-tick) (point)))))))
   2247       (error (message "Company: An error occurred in post-command")
   2248              (message "%s" (error-message-string err))
   2249              (company-cancel))))
   2250   (company-install-map))
   2251 
   2252 (defun company--idle-delay ()
   2253   (let ((delay
   2254           (if (functionp company-idle-delay)
   2255               (funcall company-idle-delay)
   2256             company-idle-delay)))
   2257     (if (memql delay '(t 0 0.0))
   2258         0.01
   2259       delay)))
   2260 
   2261 (defvar company--begin-inhibit-commands '(company-abort
   2262                                           company-complete-mouse
   2263                                           company-complete
   2264                                           company-complete-common
   2265                                           company-complete-selection
   2266                                           company-complete-tooltip-row)
   2267   "List of commands after which idle completion is (still) disabled when
   2268 `company-begin-commands' is t.")
   2269 
   2270 (defun company--should-begin ()
   2271   (if (eq t company-begin-commands)
   2272       (not (memq this-command company--begin-inhibit-commands))
   2273     (or
   2274      (memq this-command company-begin-commands)
   2275      (and (symbolp this-command) (get this-command 'company-begin)))))
   2276 
   2277 ;;; search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2278 
   2279 (defcustom company-search-regexp-function #'regexp-quote
   2280   "Function to construct the search regexp from input.
   2281 It's called with one argument, the current search input.  It must return
   2282 either a regexp without groups, or one where groups don't intersect and
   2283 each one wraps a part of the input string."
   2284   :type '(choice
   2285           (const :tag "Exact match" regexp-quote)
   2286           (const :tag "Words separated with spaces" company-search-words-regexp)
   2287           (const :tag "Words separated with spaces, in any order"
   2288                  company-search-words-in-any-order-regexp)
   2289           (const :tag "All characters in given order, with anything in between"
   2290                  company-search-flex-regexp)))
   2291 
   2292 (defvar-local company-search-string "")
   2293 
   2294 (defvar company-search-lighter '(" "
   2295                                  (company-search-filtering "Filter" "Search")
   2296                                  ": \""
   2297                                  company-search-string
   2298                                  "\""))
   2299 
   2300 (defvar-local company-search-filtering nil
   2301   "Non-nil to filter the completion candidates by the search string")
   2302 
   2303 (defvar-local company--search-old-selection 0)
   2304 
   2305 (defvar-local company--search-old-changed nil)
   2306 
   2307 (defun company-search-words-regexp (input)
   2308   (mapconcat (lambda (word) (format "\\(%s\\)" (regexp-quote word)))
   2309              (split-string input " +" t) ".*"))
   2310 
   2311 (defun company-search-words-in-any-order-regexp (input)
   2312   (let* ((words (mapcar (lambda (word) (format "\\(%s\\)" (regexp-quote word)))
   2313                         (split-string input " +" t)))
   2314          (permutations (company--permutations words)))
   2315     (mapconcat (lambda (words)
   2316                  (mapconcat #'identity words ".*"))
   2317                permutations
   2318                "\\|")))
   2319 
   2320 (defun company-search-flex-regexp (input)
   2321   (if (zerop (length input))
   2322       ""
   2323     (concat (regexp-quote (string (aref input 0)))
   2324             (mapconcat (lambda (c)
   2325                          (concat "[^" (string c) "]*"
   2326                                  (regexp-quote (string c))))
   2327                        (substring input 1) ""))))
   2328 
   2329 (defun company--permutations (lst)
   2330   (if (not lst)
   2331       '(nil)
   2332     ;; FIXME: Replace with `mapcan' in Emacs 26.
   2333     (cl-mapcan
   2334      (lambda (e)
   2335        (mapcar (lambda (perm) (cons e perm))
   2336                (company--permutations (cl-remove e lst :count 1))))
   2337      lst)))
   2338 
   2339 (defun company--search (text lines)
   2340   (let ((re (funcall company-search-regexp-function text))
   2341         (i 0))
   2342     (cl-dolist (line lines)
   2343       (when (string-match-p re line)
   2344         (cl-return i))
   2345       (cl-incf i))))
   2346 
   2347 (defun company-search-printing-char ()
   2348   (interactive)
   2349   (company--search-assert-enabled)
   2350   (let* ((event-type (event-basic-type last-command-event))
   2351          (event-string (if (characterp event-type)
   2352                            (string last-command-event)
   2353                          ;; Handle key press on the keypad.
   2354                          (let ((name (symbol-name event-type)))
   2355                            (if (string-match "kp-\\([0-9]\\)" name)
   2356                                (match-string 1 name)
   2357                              (error "Unexpected printing char input")))))
   2358          (ss (concat company-search-string event-string)))
   2359     (when company-search-filtering
   2360       (company--search-update-predicate ss))
   2361     (company--search-update-string ss)))
   2362 
   2363 (defun company--search-update-predicate (ss)
   2364   (let* ((re (funcall company-search-regexp-function ss))
   2365          (company-candidates-predicate
   2366           (and (not (string= re ""))
   2367                company-search-filtering
   2368                (lambda (candidate) (string-match re candidate))))
   2369          (cc (company-calculate-candidates company-prefix
   2370                                            (company-call-backend 'ignore-case))))
   2371     (unless cc (user-error "No match"))
   2372     (company-update-candidates cc)))
   2373 
   2374 (defun company--search-update-string (new)
   2375   (let* ((selection (or company-selection 0))
   2376          (pos (company--search new (nthcdr selection company-candidates))))
   2377     (if (null pos)
   2378         (ding)
   2379       (setq company-search-string new)
   2380       (company-set-selection (+ selection pos) t))))
   2381 
   2382 (defun company--search-assert-input ()
   2383   (company--search-assert-enabled)
   2384   (when (string= company-search-string "")
   2385     (user-error "Empty search string")))
   2386 
   2387 (defun company-search-repeat-forward ()
   2388   "Repeat the incremental search in completion candidates forward."
   2389   (interactive)
   2390   (company--search-assert-input)
   2391   (let* ((selection (or company-selection 0))
   2392          (pos (company--search company-search-string
   2393                               (cdr (nthcdr selection company-candidates)))))
   2394     (if (null pos)
   2395         (ding)
   2396       (company-set-selection (+ selection pos 1) t))))
   2397 
   2398 (defun company-search-repeat-backward ()
   2399   "Repeat the incremental search in completion candidates backwards."
   2400   (interactive)
   2401   (company--search-assert-input)
   2402   (let* ((selection (or company-selection 0))
   2403          (pos (company--search company-search-string
   2404                               (nthcdr (- company-candidates-length
   2405                                          selection)
   2406                                       (reverse company-candidates)))))
   2407     (if (null pos)
   2408         (ding)
   2409       (company-set-selection (- selection pos 1) t))))
   2410 
   2411 (defun company-search-toggle-filtering ()
   2412   "Toggle `company-search-filtering'."
   2413   (interactive)
   2414   (company--search-assert-enabled)
   2415   (setq company-search-filtering (not company-search-filtering))
   2416   (let ((ss company-search-string))
   2417     (company--search-update-predicate ss)
   2418     (company--search-update-string ss)))
   2419 
   2420 (defun company-search-abort ()
   2421   "Abort searching the completion candidates."
   2422   (interactive)
   2423   (company--search-assert-enabled)
   2424   (company-search-mode 0)
   2425   (company-set-selection company--search-old-selection t)
   2426   (setq company-selection-changed company--search-old-changed))
   2427 
   2428 (defun company-search-other-char ()
   2429   (interactive)
   2430   (company--search-assert-enabled)
   2431   (company-search-mode 0)
   2432   (company--unread-this-command-keys))
   2433 
   2434 (defun company-search-delete-char ()
   2435   (interactive)
   2436   (company--search-assert-enabled)
   2437   (if (string= company-search-string "")
   2438       (ding)
   2439     (let ((ss (substring company-search-string 0 -1)))
   2440       (when company-search-filtering
   2441         (company--search-update-predicate ss))
   2442       (company--search-update-string ss))))
   2443 
   2444 (defvar company-search-map
   2445   (let ((i 0)
   2446         (keymap (make-keymap)))
   2447     (if (fboundp 'max-char)
   2448         (set-char-table-range (nth 1 keymap) (cons #x100 (max-char))
   2449                               'company-search-printing-char)
   2450       (with-no-warnings
   2451         ;; obsolete in Emacs 23
   2452         (let ((l (generic-character-list))
   2453               (table (nth 1 keymap)))
   2454           (while l
   2455             (set-char-table-default table (car l) 'company-search-printing-char)
   2456             (setq l (cdr l))))))
   2457     (define-key keymap [t] 'company-search-other-char)
   2458     (while (< i ?\s)
   2459       (define-key keymap (make-string 1 i) 'company-search-other-char)
   2460       (cl-incf i))
   2461     (while (< i 256)
   2462       (define-key keymap (vector i) 'company-search-printing-char)
   2463       (cl-incf i))
   2464     (dotimes (i 10)
   2465       (define-key keymap (kbd (format "<kp-%d>" i)) 'company-search-printing-char))
   2466     (let ((meta-map (make-sparse-keymap)))
   2467       (define-key keymap (char-to-string meta-prefix-char) meta-map)
   2468       (define-key keymap [escape] meta-map))
   2469     (define-key keymap (vector meta-prefix-char t) 'company-search-other-char)
   2470     (define-key keymap (kbd "C-n") 'company-select-next-or-abort)
   2471     (define-key keymap (kbd "C-p") 'company-select-previous-or-abort)
   2472     (define-key keymap (kbd "M-n") 'company--select-next-and-warn)
   2473     (define-key keymap (kbd "M-p") 'company--select-previous-and-warn)
   2474     (define-key keymap (kbd "<down>") 'company-select-next-or-abort)
   2475     (define-key keymap (kbd "<up>") 'company-select-previous-or-abort)
   2476     (define-key keymap "\e\e\e" 'company-search-other-char)
   2477     (define-key keymap [escape escape escape] 'company-search-other-char)
   2478     (define-key keymap (kbd "DEL") 'company-search-delete-char)
   2479     (define-key keymap [backspace] 'company-search-delete-char)
   2480     (define-key keymap "\C-g" 'company-search-abort)
   2481     (define-key keymap "\C-s" 'company-search-repeat-forward)
   2482     (define-key keymap "\C-r" 'company-search-repeat-backward)
   2483     (define-key keymap "\C-o" 'company-search-toggle-filtering)
   2484     (company-keymap--bind-quick-access keymap)
   2485     keymap)
   2486   "Keymap used for incrementally searching the completion candidates.")
   2487 
   2488 (define-minor-mode company-search-mode
   2489   "Search mode for completion candidates.
   2490 Don't start this directly, use `company-search-candidates' or
   2491 `company-filter-candidates'."
   2492   :lighter company-search-lighter
   2493   (if company-search-mode
   2494       (if (company-manual-begin)
   2495           (progn
   2496             (setq company--search-old-selection company-selection
   2497                   company--search-old-changed company-selection-changed)
   2498             (company-call-frontends 'update)
   2499             (company-enable-overriding-keymap company-search-map))
   2500         (setq company-search-mode nil))
   2501     (kill-local-variable 'company-search-string)
   2502     (kill-local-variable 'company-search-filtering)
   2503     (kill-local-variable 'company--search-old-selection)
   2504     (kill-local-variable 'company--search-old-changed)
   2505     (when company-backend
   2506       (company--search-update-predicate "")
   2507       (company-call-frontends 'update))
   2508     (company-enable-overriding-keymap company-active-map)))
   2509 
   2510 (defun company--search-assert-enabled ()
   2511   (company-assert-enabled)
   2512   (unless company-search-mode
   2513     (company-uninstall-map)
   2514     (user-error "Company not in search mode")))
   2515 
   2516 (defun company-search-candidates ()
   2517   "Start searching the completion candidates incrementally.
   2518 
   2519 \\<company-search-map>Search can be controlled with the commands:
   2520 - `company-search-repeat-forward' (\\[company-search-repeat-forward])
   2521 - `company-search-repeat-backward' (\\[company-search-repeat-backward])
   2522 - `company-search-abort' (\\[company-search-abort])
   2523 - `company-search-delete-char' (\\[company-search-delete-char])
   2524 
   2525 Regular characters are appended to the search string.
   2526 
   2527 Customize `company-search-regexp-function' to change how the input
   2528 is interpreted when searching.
   2529 
   2530 The command `company-search-toggle-filtering' (\\[company-search-toggle-filtering])
   2531 uses the search string to filter the completion candidates."
   2532   (interactive)
   2533   (company-search-mode 1))
   2534 
   2535 (defun company-filter-candidates ()
   2536   "Start filtering the completion candidates incrementally.
   2537 This works the same way as `company-search-candidates' immediately
   2538 followed by `company-search-toggle-filtering'."
   2539   (interactive)
   2540   (company-search-mode 1)
   2541   (setq company-search-filtering t))
   2542 
   2543 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2544 
   2545 (defun company-select-next (&optional arg)
   2546   "Select the next candidate in the list.
   2547 
   2548 With ARG, move by that many elements.
   2549 When `company-selection-default' is nil, add a special pseudo candidates
   2550 meant for no selection."
   2551   (interactive "p")
   2552   (when (company-manual-begin)
   2553     (let ((selection (+ (or arg 1)
   2554                         (or company-selection
   2555                             company-selection-default
   2556                             -1))))
   2557       (company-set-selection selection))))
   2558 
   2559 (defun company-select-previous (&optional arg)
   2560   "Select the previous candidate in the list.
   2561 
   2562 With ARG, move by that many elements."
   2563   (interactive "p")
   2564   (company-select-next (if arg (- arg) -1)))
   2565 
   2566 (defun company-select-next-or-abort (&optional arg)
   2567   "Select the next candidate if more than one, else abort
   2568 and invoke the normal binding.
   2569 
   2570 With ARG, move by that many elements."
   2571   (interactive "p")
   2572   (if (or (not company-selection)
   2573           (> company-candidates-length 1))
   2574       (company-select-next arg)
   2575     (company-abort)
   2576     (company--unread-this-command-keys)))
   2577 
   2578 (defun company-select-previous-or-abort (&optional arg)
   2579   "Select the previous candidate if more than one, else abort
   2580 and invoke the normal binding.
   2581 
   2582 With ARG, move by that many elements."
   2583   (interactive "p")
   2584   (if (> company-candidates-length 1)
   2585       (company-select-previous arg)
   2586     (company-abort)
   2587     (company--unread-this-command-keys)))
   2588 
   2589 (defun company-select-first ()
   2590   "Select the first completion candidate."
   2591   (interactive)
   2592   (company-set-selection 0))
   2593 
   2594 (defun company-select-last ()
   2595   "Select the last completion candidate."
   2596   (interactive)
   2597   (company-set-selection (1- company-candidates-length)))
   2598 
   2599 (defun company-next-page ()
   2600   "Select the candidate one page further."
   2601   (interactive)
   2602   (when (company-manual-begin)
   2603     (if (and company-selection-wrap-around
   2604              (= company-selection (1- company-candidates-length)))
   2605         (company-set-selection 0)
   2606       (let (company-selection-wrap-around)
   2607         (company-set-selection (+ company-selection
   2608                                   company-tooltip-limit))))))
   2609 
   2610 (defun company-previous-page ()
   2611   "Select the candidate one page earlier."
   2612   (interactive)
   2613   (when (company-manual-begin)
   2614     (if (and company-selection-wrap-around
   2615              (zerop company-selection))
   2616         (company-set-selection (1- company-candidates-length))
   2617       (let (company-selection-wrap-around)
   2618         (company-set-selection (- company-selection
   2619                                   company-tooltip-limit))))))
   2620 
   2621 (defun company--event-col-row (event)
   2622   (company--posn-col-row (event-start event)))
   2623 
   2624 (defvar company-mouse-event nil
   2625   "Holds the mouse event from `company-select-mouse'.
   2626 For use in the `select-mouse' frontend action.  `let'-bound.")
   2627 
   2628 (defun company-select-mouse (event)
   2629   "Select the candidate picked by the mouse."
   2630   (interactive "e")
   2631   (or (let ((company-mouse-event event))
   2632         (cl-some #'identity (company-call-frontends 'select-mouse)))
   2633       (progn
   2634         (company-abort)
   2635         (company--unread-this-command-keys)
   2636         nil)))
   2637 
   2638 (defun company-complete-mouse (event)
   2639   "Insert the candidate picked by the mouse."
   2640   (interactive "e")
   2641   (when (company-select-mouse event)
   2642     (company-complete-selection)))
   2643 
   2644 (defun company-complete-selection ()
   2645   "Insert the selected candidate."
   2646   (interactive)
   2647   (when (and (company-manual-begin) company-selection)
   2648     (let ((result (nth company-selection company-candidates)))
   2649       (company-finish result))))
   2650 
   2651 (defun company-complete-common ()
   2652   "Insert the common part of all candidates."
   2653   (interactive)
   2654   (when (company-manual-begin)
   2655     (if (and (not (cdr company-candidates))
   2656              (equal company-common (car company-candidates)))
   2657         (company-complete-selection)
   2658       (company--insert-candidate company-common))))
   2659 
   2660 (defun company-complete-common-or-cycle (&optional arg)
   2661   "Insert the common part of all candidates, or select the next one.
   2662 
   2663 With ARG, move by that many elements."
   2664   (interactive "p")
   2665   (when (company-manual-begin)
   2666     (let ((tick (buffer-chars-modified-tick)))
   2667       (call-interactively 'company-complete-common)
   2668       (when (eq tick (buffer-chars-modified-tick))
   2669         (let ((company-selection-wrap-around t)
   2670               (current-prefix-arg arg))
   2671           (call-interactively 'company-select-next))))))
   2672 
   2673 (defun company-complete-common-or-show-delayed-tooltip ()
   2674   "Insert the common part of all candidates, or show a tooltip."
   2675   (interactive)
   2676   (when (company-manual-begin)
   2677     (let ((tick (buffer-chars-modified-tick)))
   2678       (call-interactively 'company-complete-common)
   2679       (when (eq tick (buffer-chars-modified-tick))
   2680           (let ((company-tooltip-idle-delay 0.0))
   2681             (company-complete)
   2682             (and company-candidates
   2683                  (company-call-frontends 'post-command)))))))
   2684 
   2685 (defun company-indent-or-complete-common (arg)
   2686   "Indent the current line or region, or complete the common part."
   2687   (interactive "P")
   2688   (cond
   2689    ((use-region-p)
   2690     (indent-region (region-beginning) (region-end)))
   2691    ((memq indent-line-function
   2692           '(indent-relative indent-relative-maybe))
   2693     (company-complete-common))
   2694    ((let ((old-point (point))
   2695           (old-tick (buffer-chars-modified-tick))
   2696           (tab-always-indent t))
   2697       (indent-for-tab-command arg)
   2698       (when (and (eq old-point (point))
   2699                  (eq old-tick (buffer-chars-modified-tick)))
   2700         (company-complete-common))))))
   2701 
   2702 (defun company-select-next-if-tooltip-visible-or-complete-selection ()
   2703   "Insert selection if appropriate, or select the next candidate.
   2704 Insert selection if only preview is showing or only one candidate,
   2705 otherwise select the next candidate."
   2706   (interactive)
   2707   (if (and (company-tooltip-visible-p) (> company-candidates-length 1))
   2708       (call-interactively 'company-select-next)
   2709     (call-interactively 'company-complete-selection)))
   2710 
   2711 ;;;###autoload
   2712 (defun company-complete ()
   2713   "Insert the common part of all candidates or the current selection.
   2714 The first time this is called, the common part is inserted, the second
   2715 time, or when the selection has been changed, the selected candidate is
   2716 inserted."
   2717   (interactive)
   2718   (when (company-manual-begin)
   2719     (if (or company-selection-changed
   2720             (and (eq real-last-command 'company-complete)
   2721                  (eq last-command 'company-complete-common)))
   2722         (call-interactively 'company-complete-selection)
   2723       (call-interactively 'company-complete-common)
   2724       (when company-candidates
   2725         (setq this-command 'company-complete-common)))))
   2726 
   2727 (define-obsolete-function-alias
   2728   'company-complete-number
   2729   'company-complete-tooltip-row
   2730   "0.10.0")
   2731 
   2732 (defun company-complete-tooltip-row (number)
   2733   "Insert a candidate visible on the tooltip's row NUMBER.
   2734 
   2735 Inserts one of the first ten candidates,
   2736 numbered according to the current scrolling position starting with 1.
   2737 
   2738 When called interactively, uses the last typed digit, stripping the
   2739 modifiers and translating 0 into 10, so `M-1' inserts the first visible
   2740 candidate, and `M-0' insert to 10th one.
   2741 
   2742 To show hint numbers beside the candidates, enable `company-show-quick-access'."
   2743   (interactive
   2744    (list (let* ((type (event-basic-type last-command-event))
   2745                 (char (if (characterp type)
   2746                           ;; Number on the main row.
   2747                           type
   2748                         ;; Keypad number, if bound directly.
   2749                         (car (last (string-to-list (symbol-name type))))))
   2750                 (number (- char ?0)))
   2751            (if (zerop number) 10 number))))
   2752   (company--complete-nth (1- number)))
   2753 
   2754 (defun company-complete-quick-access (row)
   2755   "Insert a candidate visible on a ROW matched by a quick-access key binding.
   2756 See `company-quick-access-keys' for more details."
   2757   (interactive
   2758    (list (let* ((event-type (event-basic-type last-command-event))
   2759                 (event-string (if (characterp event-type)
   2760                                   (string event-type)
   2761                                 (error "Unexpected input"))))
   2762            (cl-position event-string company-quick-access-keys :test 'equal))))
   2763   (when row
   2764     (company--complete-nth row)))
   2765 
   2766 (defvar-local company-tooltip-offset 0
   2767   "Current scrolling state of the tooltip.
   2768 Represented by the index of the first visible completion candidate
   2769 from the candidates list.")
   2770 
   2771 (defun company--complete-nth (row)
   2772   "Insert a candidate visible on the tooltip's zero-based ROW."
   2773   (when (company-manual-begin)
   2774     (and (or (< row 0) (>= row (- company-candidates-length
   2775                                   company-tooltip-offset)))
   2776          (user-error "No candidate on the row number %d" row))
   2777     (company-finish (nth (+ row company-tooltip-offset)
   2778                          company-candidates))))
   2779 
   2780 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2781 
   2782 (defconst company-space-strings-limit 100)
   2783 
   2784 (defconst company-space-strings
   2785   (let (lst)
   2786     (dotimes (i company-space-strings-limit)
   2787       (push (make-string (- company-space-strings-limit 1 i) ?\  ) lst))
   2788     (apply 'vector lst)))
   2789 
   2790 (defun company-space-string (len)
   2791   (if (< len company-space-strings-limit)
   2792       (aref company-space-strings len)
   2793     (make-string len ?\ )))
   2794 
   2795 (defun company-safe-substring (str from &optional to)
   2796   (let ((bis buffer-invisibility-spec))
   2797     (if (> from (string-width str))
   2798         ""
   2799       (with-temp-buffer
   2800         (setq buffer-invisibility-spec bis)
   2801         (insert str)
   2802         (move-to-column from)
   2803         (let ((beg (point)))
   2804           (if to
   2805               (progn
   2806                 (move-to-column to)
   2807                 (concat (buffer-substring beg (point))
   2808                         (let ((padding (- to (current-column))))
   2809                           (when (> padding 0)
   2810                             (company-space-string padding)))))
   2811             (buffer-substring beg (point-max))))))))
   2812 
   2813 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2814 
   2815 (defvar-local company-last-metadata nil)
   2816 
   2817 (defun company-fetch-metadata ()
   2818   (let ((selected (nth (or company-selection 0) company-candidates)))
   2819     (unless (eq selected (car company-last-metadata))
   2820       (setq company-last-metadata
   2821             (cons selected (company-call-backend 'meta selected))))
   2822     (cdr company-last-metadata)))
   2823 
   2824 (defun company-doc-buffer (&optional string)
   2825   (with-current-buffer (get-buffer-create "*company-documentation*")
   2826     (erase-buffer)
   2827     (fundamental-mode)
   2828     (when string
   2829       (save-excursion
   2830         (insert string)
   2831         (visual-line-mode)))
   2832     (current-buffer)))
   2833 
   2834 (defvar company--electric-saved-window-configuration nil)
   2835 
   2836 (defvar company--electric-commands
   2837   '(scroll-other-window scroll-other-window-down mwheel-scroll)
   2838   "List of Commands that won't break out of electric commands.")
   2839 
   2840 (defun company--electric-command-p ()
   2841   (memq this-command company--electric-commands))
   2842 
   2843 (defun company--electric-restore-window-configuration ()
   2844   "Restore window configuration (after electric commands)."
   2845   (when (and company--electric-saved-window-configuration
   2846              (not (company--electric-command-p)))
   2847     (set-window-configuration company--electric-saved-window-configuration)
   2848     (setq company--electric-saved-window-configuration nil)))
   2849 
   2850 (defmacro company--electric-do (&rest body)
   2851   (declare (indent 0) (debug t))
   2852   `(when company-candidates
   2853      (cl-assert (null company--electric-saved-window-configuration))
   2854      (setq company--electric-saved-window-configuration (current-window-configuration))
   2855      (let ((height (window-height))
   2856            (row (company--row)))
   2857        ,@body
   2858        (and (< (window-height) height)
   2859             (< (- (window-height) row 2) company-tooltip-limit)
   2860             (recenter (- (window-height) row 2))))))
   2861 
   2862 (defun company--unread-this-command-keys ()
   2863   (when (> (length (this-command-keys)) 0)
   2864     (setq unread-command-events (nconc
   2865                                  (listify-key-sequence (this-command-keys))
   2866                                  unread-command-events))
   2867     (clear-this-command-keys t)))
   2868 
   2869 (defun company--show-doc-buffer ()
   2870   "Show the documentation buffer for the selection."
   2871   (let ((other-window-scroll-buffer)
   2872         (selection (or company-selection 0)))
   2873       (let* ((selected (nth selection company-candidates))
   2874              (doc-buffer (or (company-call-backend 'doc-buffer selected)
   2875                              (user-error "No documentation available")))
   2876              start)
   2877         (when (consp doc-buffer)
   2878           (setq start (cdr doc-buffer)
   2879                 doc-buffer (car doc-buffer)))
   2880         (setq other-window-scroll-buffer (get-buffer doc-buffer))
   2881         (let ((win (display-buffer doc-buffer t)))
   2882           (set-window-start win (if start start (point-min)))))))
   2883 
   2884 (defun company-show-doc-buffer (&optional toggle-auto-update)
   2885   "Show the documentation buffer for the selection.
   2886 With a prefix argument TOGGLE-AUTO-UPDATE, toggle the value of
   2887 `company-auto-update-doc'.  When `company-auto-update-doc' is non-nil,
   2888 automatically show the documentation buffer for each selection."
   2889   (interactive "P")
   2890   (when toggle-auto-update
   2891     (setq company-auto-update-doc (not company-auto-update-doc)))
   2892   (company--electric-do
   2893     (company--show-doc-buffer)))
   2894 (put 'company-show-doc-buffer 'company-keep t)
   2895 
   2896 (defun company-show-location ()
   2897   "Temporarily display a buffer showing the selected candidate in context."
   2898   (interactive)
   2899   (let (other-window-scroll-buffer)
   2900     (company--electric-do
   2901       (let* ((selected (nth company-selection company-candidates))
   2902              (location (company-call-backend 'location selected))
   2903              (pos (or (cdr location) (user-error "No location available")))
   2904              (buffer (or (and (bufferp (car location)) (car location))
   2905                          (find-file-noselect (car location) t))))
   2906         (setq other-window-scroll-buffer (get-buffer buffer))
   2907         (with-selected-window (display-buffer buffer t)
   2908           (save-restriction
   2909             (widen)
   2910             (if (bufferp (car location))
   2911                 (goto-char pos)
   2912               (goto-char (point-min))
   2913               (forward-line (1- pos))))
   2914           (set-window-start nil (point)))))))
   2915 (put 'company-show-location 'company-keep t)
   2916 
   2917 ;;; package functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2918 
   2919 (defvar-local company-callback nil)
   2920 
   2921 (defun company-remove-callback (&optional _ignored)
   2922   (remove-hook 'company-completion-finished-hook company-callback t)
   2923   (remove-hook 'company-completion-cancelled-hook 'company-remove-callback t)
   2924   (remove-hook 'company-completion-finished-hook 'company-remove-callback t))
   2925 
   2926 (defun company-begin-backend (backend &optional callback)
   2927   "Start a completion at point using BACKEND."
   2928   (interactive (let ((val (completing-read "Company backend: "
   2929                                            obarray
   2930                                            'functionp nil "company-")))
   2931                  (when val
   2932                    (list (intern val)))))
   2933   (when (setq company-callback callback)
   2934     (add-hook 'company-completion-finished-hook company-callback nil t))
   2935   (add-hook 'company-completion-cancelled-hook 'company-remove-callback nil t)
   2936   (add-hook 'company-completion-finished-hook 'company-remove-callback nil t)
   2937   (setq company-backend backend)
   2938   ;; Return non-nil if active.
   2939   (or (company-manual-begin)
   2940       (user-error "Cannot complete at point")))
   2941 
   2942 (defun company-begin-with (candidates
   2943                            &optional prefix-length require-match callback)
   2944   "Start a completion at point.
   2945 CANDIDATES is the list of candidates to use and PREFIX-LENGTH is the length
   2946 of the prefix that already is in the buffer before point.
   2947 It defaults to 0.
   2948 
   2949 CALLBACK is a function called with the selected result if the user
   2950 successfully completes the input.
   2951 
   2952 Example: \(company-begin-with \\='\(\"foo\" \"foobar\" \"foobarbaz\"\)\)"
   2953   (let ((begin-marker (copy-marker (point) t)))
   2954     (company-begin-backend
   2955      (lambda (command &optional arg &rest _ignored)
   2956        (pcase command
   2957          (`prefix
   2958           (when (equal (point) (marker-position begin-marker))
   2959             (buffer-substring (- (point) (or prefix-length 0)) (point))))
   2960          (`candidates
   2961           (all-completions arg candidates))
   2962          (`require-match
   2963           require-match)))
   2964      callback)))
   2965 
   2966 (declare-function find-library-name "find-func")
   2967 (declare-function lm-version "lisp-mnt")
   2968 
   2969 (defun company-version (&optional show-version)
   2970   "Get the Company version as string.
   2971 
   2972 If SHOW-VERSION is non-nil, show the version in the echo area."
   2973   (interactive (list t))
   2974   (with-temp-buffer
   2975     (require 'find-func)
   2976     (insert-file-contents (find-library-name "company"))
   2977     (require 'lisp-mnt)
   2978     (if show-version
   2979         (message "Company version: %s" (lm-version))
   2980       (lm-version))))
   2981 
   2982 (defun company-diag ()
   2983   "Pop a buffer with information about completions at point."
   2984   (interactive)
   2985   (let* ((bb company-backends)
   2986          (mode (symbol-name major-mode))
   2987          backend
   2988          (prefix (cl-loop for b in bb
   2989                           thereis (let ((company-backend b))
   2990                                     (setq backend b)
   2991                                     (company-call-backend 'prefix))))
   2992          (c-a-p-f completion-at-point-functions)
   2993          cc annotations)
   2994     (when (or (stringp prefix) (consp prefix))
   2995       (let ((company-backend backend))
   2996         (condition-case nil
   2997             (setq cc (company-call-backend 'candidates (company--prefix-str prefix))
   2998                   annotations
   2999                   (mapcar
   3000                    (lambda (c) (cons c (company-call-backend 'annotation c)))
   3001                    cc))
   3002           (error (setq annotations 'error)))))
   3003     (pop-to-buffer (get-buffer-create "*company-diag*"))
   3004     (setq buffer-read-only nil)
   3005     (erase-buffer)
   3006     (insert (format "Emacs %s (%s) of %s on %s"
   3007                     emacs-version system-configuration
   3008                     (format-time-string "%Y-%m-%d" emacs-build-time)
   3009                     emacs-build-system))
   3010     (insert "\nCompany " (company-version) "\n\n")
   3011     (insert "company-backends: " (pp-to-string bb))
   3012     (insert "\n")
   3013     (insert "Used backend: " (pp-to-string backend))
   3014     (insert "\n")
   3015     (when (if (listp backend)
   3016               (memq 'company-capf backend)
   3017             (eq backend 'company-capf))
   3018       (insert "Value of c-a-p-f: "
   3019               (pp-to-string c-a-p-f)))
   3020     (insert "Major mode: " mode)
   3021     (insert "\n")
   3022     (insert "Prefix: " (pp-to-string prefix))
   3023     (insert "\n")
   3024     (insert "Completions:")
   3025     (unless cc (insert " none"))
   3026     (if (eq annotations 'error)
   3027         (insert "(error fetching)")
   3028       (save-excursion
   3029         (dolist (c annotations)
   3030           (insert "\n  " (prin1-to-string (car c)))
   3031           (when (cdr c)
   3032             (insert " " (prin1-to-string (cdr c)))))))
   3033     (special-mode)))
   3034 
   3035 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3036 
   3037 (defvar-local company--tooltip-current-width 0)
   3038 
   3039 (defun company-tooltip--lines-update-offset (selection num-lines limit)
   3040   (cl-decf limit 2)
   3041   (setq company-tooltip-offset
   3042         (max (min selection company-tooltip-offset)
   3043              (- selection -1 limit)))
   3044 
   3045   (when (<= company-tooltip-offset 1)
   3046     (cl-incf limit)
   3047     (setq company-tooltip-offset 0))
   3048 
   3049   (when (>= company-tooltip-offset (- num-lines limit 1))
   3050     (cl-incf limit)
   3051     (when (= selection (1- num-lines))
   3052       (cl-decf company-tooltip-offset)
   3053       (when (<= company-tooltip-offset 1)
   3054         (setq company-tooltip-offset 0)
   3055         (cl-incf limit))))
   3056 
   3057   limit)
   3058 
   3059 (defun company-tooltip--simple-update-offset (selection _num-lines limit)
   3060   (setq company-tooltip-offset
   3061         (if (< selection company-tooltip-offset)
   3062             selection
   3063           (max company-tooltip-offset
   3064                (- selection limit -1)))))
   3065 
   3066 ;;; propertize
   3067 
   3068 (defun company-round-tab (arg)
   3069   (* (/ (+ arg tab-width) tab-width) tab-width))
   3070 
   3071 (defun company-plainify (str)
   3072   (let ((prefix (get-text-property 0 'line-prefix str)))
   3073     (when prefix ; Keep the original value unmodified, for no special reason.
   3074       (setq str (concat prefix str))
   3075       (remove-text-properties 0 (length str) '(line-prefix) str)))
   3076   (let* ((pieces (split-string str "\t"))
   3077          (copy pieces))
   3078     (while (cdr copy)
   3079       (setcar copy (company-safe-substring
   3080                     (car copy) 0 (company-round-tab (string-width (car copy)))))
   3081       (pop copy))
   3082     (apply 'concat pieces)))
   3083 
   3084 (defun company--common-or-matches (value)
   3085   (let ((matches (company-call-backend 'match value)))
   3086     (when (and matches
   3087                company-common
   3088                (listp matches)
   3089                (= 1 (length matches))
   3090                (= 0 (caar matches))
   3091                (> (length company-common) (cdar matches)))
   3092       (setq matches nil))
   3093     (when (integerp matches)
   3094       (setq matches `((0 . ,matches))))
   3095     (or matches
   3096         (and company-common `((0 . ,(length company-common))))
   3097         nil)))
   3098 
   3099 (defun company-fill-propertize (value annotation width selected left right)
   3100   (let* ((margin (length left))
   3101          (company-common (and company-common (company--clean-string company-common)))
   3102          (common (company--common-or-matches value))
   3103          (_ (setq value (company-reformat (company--pre-render value))
   3104                   annotation (and annotation (company--pre-render annotation t))))
   3105          (ann-ralign company-tooltip-align-annotations)
   3106          (ann-padding (or company-tooltip-annotation-padding 0))
   3107          (ann-truncate (< width
   3108                           (+ (length value) (length annotation)
   3109                              ann-padding)))
   3110          (ann-start (+ margin
   3111                        (if ann-ralign
   3112                            (if ann-truncate
   3113                                (+ (length value) ann-padding)
   3114                              (- width (length annotation)))
   3115                          (+ (length value) ann-padding))))
   3116          (ann-end (min (+ ann-start (length annotation)) (+ margin width)))
   3117          (line (concat left
   3118                        (if (or ann-truncate (not ann-ralign))
   3119                            (company-safe-substring
   3120                             (concat value
   3121                                     (when annotation
   3122                                       (company-space-string ann-padding))
   3123                                     annotation)
   3124                             0 width)
   3125                          (concat
   3126                           (company-safe-substring value 0
   3127                                                   (- width (length annotation)))
   3128                           annotation))
   3129                        right)))
   3130     (setq width (+ width margin (length right)))
   3131 
   3132     (font-lock-append-text-property 0 width 'mouse-face
   3133                                     'company-tooltip-mouse
   3134                                     line)
   3135     (when (< ann-start ann-end)
   3136       (add-face-text-property ann-start ann-end
   3137                               (if selected
   3138                                   'company-tooltip-annotation-selection
   3139                                 'company-tooltip-annotation)
   3140                               t line))
   3141     (cl-loop
   3142      with width = (- width (length right))
   3143      for (comp-beg . comp-end) in common
   3144      for inline-beg = (+ margin comp-beg)
   3145      for inline-end = (min (+ margin comp-end) width)
   3146      when (< inline-beg width)
   3147      do (add-face-text-property inline-beg inline-end
   3148                                 (if selected
   3149                                     'company-tooltip-common-selection
   3150                                   'company-tooltip-common)
   3151                                 nil line))
   3152     (when (let ((re (funcall company-search-regexp-function
   3153                              company-search-string)))
   3154             (and (not (string= re ""))
   3155                  (string-match re value)))
   3156       (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks))
   3157         (let ((beg (+ margin mbeg))
   3158               (end (+ margin mend))
   3159               (width (- width (length right))))
   3160           (when (< beg width)
   3161             (add-face-text-property beg (min end width)
   3162                                     (if selected
   3163                                         'company-tooltip-search-selection
   3164                                       'company-tooltip-search)
   3165                                     nil line)))))
   3166     (when selected
   3167       (add-face-text-property 0 width 'company-tooltip-selection t line))
   3168 
   3169     (when (company-call-backend 'deprecated value)
   3170       (add-face-text-property margin
   3171                               (min
   3172                                (+ margin (length value))
   3173                                (- width (length right)))
   3174                               'company-tooltip-deprecated t line))
   3175 
   3176     (add-face-text-property 0 width 'company-tooltip t line)
   3177     line))
   3178 
   3179 (defun company--search-chunks ()
   3180   (let ((md (match-data t))
   3181         res)
   3182     (if (<= (length md) 2)
   3183         (push (cons (nth 0 md) (nth 1 md)) res)
   3184       (while (setq md (nthcdr 2 md))
   3185         (when (car md)
   3186           (push (cons (car md) (cadr md)) res))))
   3187     res))
   3188 
   3189 (defun company--pre-render (str &optional annotation-p)
   3190   (or (company-call-backend 'pre-render str annotation-p)
   3191       (progn
   3192         (when (or (text-property-not-all 0 (length str) 'face nil str)
   3193                   (text-property-not-all 0 (length str) 'mouse-face nil str))
   3194           (setq str (copy-sequence str))
   3195           (remove-text-properties 0 (length str)
   3196                                   '(face nil font-lock-face nil mouse-face nil)
   3197                                   str))
   3198         str)))
   3199 
   3200 (defun company--clean-string (str)
   3201   (replace-regexp-in-string
   3202    "\\([^[:graph:] ]\\)\\|\\(\ufeff\\)\\|[[:multibyte:]]"
   3203    (lambda (match)
   3204      (cond
   3205       ((match-beginning 1)
   3206        ;; FIXME: Better char for 'non-printable'?
   3207        ;; We shouldn't get any of these, but sometimes we might.
   3208        ;; The official "replacement character" is not supported by some fonts.
   3209        ;;"\ufffd"
   3210        "?"
   3211        )
   3212       ((match-beginning 2)
   3213        ;; Zero-width non-breakable space.
   3214        "")
   3215       ((> (string-width match) 1)
   3216        (concat
   3217         (make-string (1- (string-width match)) ?\ufeff)
   3218         match))
   3219       (t match)))
   3220    str))
   3221 
   3222 ;;; replace
   3223 
   3224 (defun company-buffer-lines (beg end)
   3225   (goto-char beg)
   3226   (let (lines lines-moved)
   3227     (while (and (not (eobp)) ; http://debbugs.gnu.org/19553
   3228                 (> (setq lines-moved (vertical-motion 1)) 0)
   3229                 (<= (point) end))
   3230       (let ((bound (min end (point))))
   3231         ;; A visual line can contain several physical lines (e.g. with outline's
   3232         ;; folding overlay).  Take only the first one.
   3233         (push (buffer-substring beg
   3234                                 (save-excursion
   3235                                   (goto-char beg)
   3236                                   (re-search-forward "$" bound 'move)
   3237                                   (point)))
   3238               lines))
   3239       ;; One physical line can be displayed as several visual ones as well:
   3240       ;; add empty strings to the list, to even the count.
   3241       (dotimes (_ (1- lines-moved))
   3242         (push "" lines))
   3243       (setq beg (point)))
   3244     (unless (eq beg end)
   3245       (push (buffer-substring beg end) lines))
   3246     (nreverse lines)))
   3247 
   3248 (defun company-modify-line (old new offset)
   3249   (concat (company-safe-substring old 0 offset)
   3250           new
   3251           (company-safe-substring old (+ offset (length new)))))
   3252 
   3253 (defun company--show-numbers (numbered)
   3254   (format " %s" (if (<= numbered 10)
   3255                     (mod numbered 10)
   3256                   " ")))
   3257 (make-obsolete
   3258  'company--show-numbers
   3259  "use `company-quick-access-hint-key' instead,
   3260 but adjust the expected values appropriately."
   3261  "0.10.0")
   3262 
   3263 (defsubst company--window-height ()
   3264   (if (fboundp 'window-screen-lines)
   3265       (floor (window-screen-lines))
   3266     (window-body-height)))
   3267 
   3268 (defun company--window-width ()
   3269   (let ((ww (window-body-width)))
   3270     ;; Account for the line continuation column.
   3271     (when (zerop (cadr (window-fringes)))
   3272       (cl-decf ww))
   3273     (when (bound-and-true-p display-line-numbers)
   3274       (cl-decf ww (+ 2 (line-number-display-width))))
   3275     ;; whitespace-mode with newline-mark
   3276     (when (and buffer-display-table
   3277                (aref buffer-display-table ?\n))
   3278       (cl-decf ww (1- (length (aref buffer-display-table ?\n)))))
   3279     ww))
   3280 
   3281 (defun company--face-attribute (face attr)
   3282   ;; Like `face-attribute', but accounts for faces that have been remapped to
   3283   ;; another face, a list of faces, or a face spec.
   3284   (cond ((null face) nil)
   3285         ((symbolp face)
   3286          (let ((remap (cdr (assq face face-remapping-alist))))
   3287            (if remap
   3288                (company--face-attribute
   3289                 ;; Faces can be remapped to their unremapped selves, but that
   3290                 ;; would cause us infinite recursion.
   3291                 (if (listp remap) (remq face remap) remap)
   3292                 attr)
   3293              (face-attribute face attr nil t))))
   3294         ((keywordp (car-safe face))
   3295          (or (plist-get face attr)
   3296              (company--face-attribute (plist-get face :inherit) attr)))
   3297         ((listp face)
   3298          (cl-find-if #'stringp
   3299                      (mapcar (lambda (f) (company--face-attribute f attr))
   3300                              face)))))
   3301 
   3302 (defun company--replacement-string (lines column-offset old column nl &optional align-top)
   3303   (cl-decf column column-offset)
   3304 
   3305   (when (< column 0) (setq column 0))
   3306 
   3307   (when (and align-top company-tooltip-flip-when-above)
   3308     (setq lines (reverse lines)))
   3309 
   3310   (let ((width (length (car lines)))
   3311         (remaining-cols (- (+ (company--window-width) (window-hscroll))
   3312                            column)))
   3313     (when (> width remaining-cols)
   3314       (cl-decf column (- width remaining-cols))))
   3315 
   3316   (let (new)
   3317     (when align-top
   3318       ;; untouched lines first
   3319       (dotimes (_ (- (length old) (length lines)))
   3320         (push (pop old) new)))
   3321     ;; length into old lines.
   3322     (while old
   3323       (push (company-modify-line (pop old) (pop lines) column)
   3324             new))
   3325     ;; Append whole new lines.
   3326     (while lines
   3327       (push (concat (company-space-string column) (pop lines))
   3328             new))
   3329 
   3330     ;; XXX: Also see branch 'more-precise-extend'.
   3331     (let* ((nl-face `(,@(when (version<= "27" emacs-version)
   3332                           '(:extend t))
   3333                      :inverse-video nil
   3334                      :background ,(or (company--face-attribute 'default :background)
   3335                                      (face-attribute 'default :background nil t))))
   3336            (str (apply #'concat
   3337                        (when nl " \n")
   3338                        (cl-mapcan
   3339                         ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=42552#23
   3340                         (lambda (line) (list line (propertize "\n" 'face nl-face)))
   3341                         (nreverse new)))))
   3342       ;; https://debbugs.gnu.org/38563
   3343       (add-face-text-property 0 (length str) 'default t str)
   3344       (when nl (put-text-property 0 1 'cursor t str))
   3345       str)))
   3346 
   3347 (defun company--create-lines (selection limit)
   3348   (let ((len company-candidates-length)
   3349         (window-width (company--window-width))
   3350         (company-tooltip-annotation-padding
   3351          (or company-tooltip-annotation-padding
   3352              (if company-tooltip-align-annotations 1 0)))
   3353         left-margins
   3354         left-margin-size
   3355         lines
   3356         width
   3357         lines-copy
   3358         items
   3359         previous
   3360         remainder
   3361         scrollbar-bounds)
   3362 
   3363     ;; Maybe clear old offset.
   3364     (when (< len (+ company-tooltip-offset limit))
   3365       (setq company-tooltip-offset 0))
   3366 
   3367     (let ((selection (or selection 0)))
   3368       ;; Scroll to offset.
   3369       (if (eq company-tooltip-offset-display 'lines)
   3370           (setq limit (company-tooltip--lines-update-offset selection len limit))
   3371         (company-tooltip--simple-update-offset selection len limit))
   3372 
   3373       (cond
   3374        ((eq company-tooltip-offset-display 'scrollbar)
   3375         (setq scrollbar-bounds (company--scrollbar-bounds company-tooltip-offset
   3376                                                           limit len)))
   3377        ((eq company-tooltip-offset-display 'lines)
   3378         (when (> company-tooltip-offset 0)
   3379           (setq previous (format "...(%d)" company-tooltip-offset)))
   3380         (setq remainder (- len limit company-tooltip-offset)
   3381               remainder (when (> remainder 0)
   3382                           (setq remainder (format "...(%d)" remainder)))))))
   3383 
   3384     (when selection
   3385       (cl-decf selection company-tooltip-offset))
   3386 
   3387     (setq width (max (length previous) (length remainder))
   3388           lines (nthcdr company-tooltip-offset company-candidates)
   3389           len (min limit len)
   3390           lines-copy lines)
   3391 
   3392     (when scrollbar-bounds (cl-decf window-width))
   3393 
   3394     (when company-format-margin-function
   3395       (let ((lines-copy lines-copy)
   3396             res)
   3397         (dotimes (i len)
   3398           (push (funcall company-format-margin-function
   3399                          (pop lines-copy)
   3400                          (equal selection i))
   3401                 res))
   3402         (setq left-margins (nreverse res))))
   3403 
   3404     ;; XXX: format-function outputting shorter strings than the
   3405     ;; default margin is not supported (yet?).
   3406     (setq left-margin-size (apply #'max company-tooltip-margin
   3407                                   (mapcar #'length left-margins)))
   3408 
   3409     (cl-decf window-width company-tooltip-margin)
   3410     (cl-decf window-width left-margin-size)
   3411 
   3412     (dotimes (_ len)
   3413       (let* ((value (pop lines-copy))
   3414              (annotation (company-call-backend 'annotation value))
   3415              (left (or (pop left-margins)
   3416                        (company-space-string left-margin-size))))
   3417         (setq value (company--clean-string value))
   3418         (when annotation
   3419           (setq annotation (company--clean-string annotation))
   3420           (when company-tooltip-align-annotations
   3421             ;; `lisp-completion-at-point' adds a space.
   3422             (setq annotation (string-trim-left annotation))))
   3423         (push (list value annotation left) items)
   3424         (setq width (max (+ (length value)
   3425                             (if annotation
   3426                                 (+ (length annotation)
   3427                                    company-tooltip-annotation-padding)
   3428                               (length annotation)))
   3429                          width))))
   3430 
   3431     (setq width (min window-width
   3432                      company-tooltip-maximum-width
   3433                      (max company-tooltip-minimum-width
   3434                           (if company-show-quick-access
   3435                               (+ 2 width)
   3436                             width))))
   3437 
   3438     (when company-tooltip-width-grow-only
   3439       (setq width (max company--tooltip-current-width width))
   3440       (setq company--tooltip-current-width width))
   3441 
   3442     (let ((items (nreverse items))
   3443           (row (if company-show-quick-access 0 99999))
   3444           new)
   3445       (when previous
   3446         (push (company--scrollpos-line previous width left-margin-size) new))
   3447 
   3448       (dotimes (i len)
   3449         (let* ((item (pop items))
   3450                (str (car item))
   3451                (annotation (cadr item))
   3452                (left (nth 2 item))
   3453                (right (company-space-string company-tooltip-margin))
   3454                (width width)
   3455                (selected (equal selection i)))
   3456           (when company-show-quick-access
   3457             (let ((quick-access (gv-ref (if (eq company-show-quick-access 'left)
   3458                                             left right)))
   3459                   (qa-hint (company-tooltip--format-quick-access-hint
   3460                             row selected)))
   3461               (cl-decf width (string-width qa-hint))
   3462               (setf (gv-deref quick-access)
   3463                     (concat qa-hint (gv-deref quick-access))))
   3464             (cl-incf row))
   3465           (push (concat
   3466                  (company-fill-propertize str annotation
   3467                                           width selected
   3468                                           left
   3469                                           right)
   3470                  (when scrollbar-bounds
   3471                    (company--scrollbar i scrollbar-bounds)))
   3472                 new)))
   3473 
   3474       (when remainder
   3475         (push (company--scrollpos-line remainder width left-margin-size) new))
   3476 
   3477       (cons
   3478        left-margin-size
   3479        (nreverse new)))))
   3480 
   3481 (defun company--scrollbar-bounds (offset limit length)
   3482   (when (> length limit)
   3483     (let* ((size (ceiling (* limit (float limit)) length))
   3484            (lower (floor (* limit (float offset)) length))
   3485            (upper (+ lower size -1)))
   3486       (cons lower upper))))
   3487 
   3488 (defun company--scrollbar (i bounds)
   3489   (propertize " " 'face
   3490               (if (and (>= i (car bounds)) (<= i (cdr bounds)))
   3491                   'company-tooltip-scrollbar-thumb
   3492                 'company-tooltip-scrollbar-track)))
   3493 
   3494 (defun company--scrollpos-line (text width fancy-margin-width)
   3495   (propertize (concat (company-space-string company-tooltip-margin)
   3496                       (company-safe-substring text 0 width)
   3497                       (company-space-string fancy-margin-width))
   3498               'face 'company-tooltip))
   3499 
   3500 (defun company-tooltip--format-quick-access-hint (row selected)
   3501   "Format a quick-access hint for outputting on a tooltip's ROW.
   3502 Value of SELECTED determines the added face."
   3503   (propertize (format "%2s" (funcall company-quick-access-hint-function row))
   3504               'face
   3505               (if selected
   3506                   'company-tooltip-quick-access-selection
   3507                 'company-tooltip-quick-access)))
   3508 
   3509 ;; show
   3510 
   3511 (defvar-local company-pseudo-tooltip-overlay nil)
   3512 
   3513 (defun company--inside-tooltip-p (event-col-row row height)
   3514   (let* ((ovl company-pseudo-tooltip-overlay)
   3515          (column (overlay-get ovl 'company-column))
   3516          (width (overlay-get ovl 'company-width))
   3517          (evt-col (car event-col-row))
   3518          (evt-row (cdr event-col-row)))
   3519     (and (>= evt-col column)
   3520          (< evt-col (+ column width))
   3521          (if (> height 0)
   3522              (and (> evt-row row)
   3523                   (<= evt-row (+ row height) ))
   3524            (and (< evt-row row)
   3525                 (>= evt-row (+ row height)))))))
   3526 
   3527 (defun company--pseudo-tooltip-height ()
   3528   "Calculate the appropriate tooltip height.
   3529 Returns a negative number if the tooltip should be displayed above point."
   3530   (let* ((lines (company--row))
   3531          (below (- (company--window-height) 1 lines)))
   3532     (if (and (< below (min company-tooltip-minimum company-candidates-length))
   3533              (> lines below))
   3534         (- (max 3 (min company-tooltip-limit lines)))
   3535       (max 3 (min company-tooltip-limit below)))))
   3536 
   3537 (defun company-pseudo-tooltip-show (row column selection)
   3538   (company-pseudo-tooltip-hide)
   3539 
   3540     (let* ((height (company--pseudo-tooltip-height))
   3541            above)
   3542 
   3543       (when (< height 0)
   3544         (setq row (+ row height -1)
   3545               above t))
   3546 
   3547       ;; This can happen in Emacs versions which allow arbitrary scrolling,
   3548       ;; such as Yamamoto's Mac Port.
   3549       (unless (pos-visible-in-window-p (window-start))
   3550         (cl-decf row))
   3551 
   3552       (let (nl beg end ov args)
   3553         (save-excursion
   3554           (setq nl (< (move-to-window-line row) row)
   3555                 beg (point)
   3556                 end (save-excursion
   3557                       (move-to-window-line (+ row (abs height)))
   3558                       (point))
   3559                 ov (make-overlay beg end nil t)
   3560                 args (list (mapcar 'company-plainify
   3561                                    (company-buffer-lines beg end))
   3562                            column nl above)))
   3563 
   3564         (setq company-pseudo-tooltip-overlay ov)
   3565         (overlay-put ov 'company-replacement-args args)
   3566 
   3567         (let* ((lines-and-offset (company--create-lines selection (abs height)))
   3568                (lines (cdr lines-and-offset))
   3569                (column-offset (car lines-and-offset)))
   3570           (overlay-put ov 'company-display
   3571                        (apply 'company--replacement-string
   3572                               lines column-offset args))
   3573           (overlay-put ov 'company-width (string-width (car lines))))
   3574 
   3575         (overlay-put ov 'company-column column)
   3576         (overlay-put ov 'company-height height))))
   3577 
   3578 (defun company-pseudo-tooltip-show-at-point (pos column-offset)
   3579   (let* ((col-row (company--col-row pos))
   3580          (col (- (car col-row) column-offset)))
   3581     (when (< col 0) (setq col 0))
   3582     (company-pseudo-tooltip-show (1+ (cdr col-row)) col company-selection)))
   3583 
   3584 (defun company-pseudo-tooltip-edit (selection)
   3585   (let* ((height (overlay-get company-pseudo-tooltip-overlay 'company-height))
   3586          (lines-and-offset  (company--create-lines selection (abs height)))
   3587          (lines (cdr lines-and-offset))
   3588          (column-offset (car lines-and-offset)))
   3589     (overlay-put company-pseudo-tooltip-overlay 'company-width
   3590                  (string-width (car lines)))
   3591     (overlay-put company-pseudo-tooltip-overlay 'company-display
   3592                  (apply 'company--replacement-string
   3593                         lines column-offset
   3594                         (overlay-get company-pseudo-tooltip-overlay
   3595                                      'company-replacement-args)))))
   3596 
   3597 (defun company-pseudo-tooltip-hide ()
   3598   (when company-pseudo-tooltip-overlay
   3599     (delete-overlay company-pseudo-tooltip-overlay)
   3600     (setq company-pseudo-tooltip-overlay nil)))
   3601 
   3602 (defun company-pseudo-tooltip-hide-temporarily ()
   3603   (when (overlayp company-pseudo-tooltip-overlay)
   3604     (overlay-put company-pseudo-tooltip-overlay 'invisible nil)
   3605     (overlay-put company-pseudo-tooltip-overlay 'line-prefix nil)
   3606     (overlay-put company-pseudo-tooltip-overlay 'before-string nil)
   3607     (overlay-put company-pseudo-tooltip-overlay 'display nil)
   3608     (overlay-put company-pseudo-tooltip-overlay 'face nil)))
   3609 
   3610 (defun company-pseudo-tooltip-unhide ()
   3611   (when company-pseudo-tooltip-overlay
   3612     (let* ((ov company-pseudo-tooltip-overlay)
   3613            (disp (overlay-get ov 'company-display)))
   3614       ;; Beat outline's folding overlays.
   3615       ;; And Flymake (53). And Flycheck (110).
   3616       (overlay-put ov 'priority 111)
   3617       ;; visual-line-mode
   3618       (when (and (memq (char-before (overlay-start ov)) '(?\s ?\t))
   3619                  ;; not eob
   3620                  (not (nth 2 (overlay-get ov 'company-replacement-args))))
   3621         (setq disp (concat "\n" disp)))
   3622       ;; No (extra) prefix for the first line.
   3623       (overlay-put ov 'line-prefix "")
   3624       (overlay-put ov 'before-string disp)
   3625       ;; `display' is better than `invisible':
   3626       ;; https://debbugs.gnu.org/18285
   3627       ;; https://debbugs.gnu.org/20847
   3628       ;; https://debbugs.gnu.org/42521
   3629       (overlay-put ov 'display "")
   3630       (overlay-put ov 'window (selected-window)))))
   3631 
   3632 (defun company-pseudo-tooltip-guard ()
   3633   (list
   3634    (save-excursion (beginning-of-visual-line))
   3635    (window-width)
   3636    (let ((ov company-pseudo-tooltip-overlay)
   3637          (overhang (save-excursion (end-of-visual-line)
   3638                                    (- (line-end-position) (point)))))
   3639      (when (>= (overlay-get ov 'company-height) 0)
   3640        (cons
   3641         (buffer-substring-no-properties (point) (overlay-start ov))
   3642         (when (>= overhang 0) overhang))))))
   3643 
   3644 (defun company-pseudo-tooltip-frontend (command)
   3645   "`company-mode' frontend similar to a tooltip but based on overlays."
   3646   (cl-case command
   3647     (pre-command (company-pseudo-tooltip-hide-temporarily))
   3648     (unhide
   3649      (let ((ov company-pseudo-tooltip-overlay))
   3650        (when (> (overlay-get ov 'company-height) 0)
   3651          ;; Sleight of hand: if the current line wraps, we adjust the
   3652          ;; start of the overlay so that the popup does not zig-zag,
   3653          ;; but don't update the popup's background.  This seems just
   3654          ;; non-annoying enough to avoid the work required for the latter.
   3655          (save-excursion
   3656            (vertical-motion 1)
   3657            (unless (= (point) (overlay-start ov))
   3658              (move-overlay ov (point) (overlay-end ov))))))
   3659      (company-pseudo-tooltip-unhide))
   3660     (post-command
   3661      (unless (when (overlayp company-pseudo-tooltip-overlay)
   3662                (let* ((ov company-pseudo-tooltip-overlay)
   3663                       (old-height (overlay-get ov 'company-height))
   3664                       (new-height (company--pseudo-tooltip-height)))
   3665                  (and
   3666                   (>= (* old-height new-height) 0)
   3667                   (>= (abs old-height) (abs new-height))
   3668                   (equal (company-pseudo-tooltip-guard)
   3669                          (overlay-get ov 'company-guard)))))
   3670        ;; Redraw needed.
   3671        (company-pseudo-tooltip-show-at-point (point) (length company-prefix))
   3672        (overlay-put company-pseudo-tooltip-overlay
   3673                     'company-guard (company-pseudo-tooltip-guard)))
   3674      (company-pseudo-tooltip-unhide))
   3675     (show (setq company--tooltip-current-width 0))
   3676     (hide (company-pseudo-tooltip-hide)
   3677           (setq company-tooltip-offset 0))
   3678     (update (when (overlayp company-pseudo-tooltip-overlay)
   3679               (company-pseudo-tooltip-edit company-selection)))
   3680     (select-mouse
   3681      (let ((event-col-row (company--event-col-row company-mouse-event))
   3682            (ovl-row (company--row))
   3683            (ovl-height (and company-pseudo-tooltip-overlay
   3684                             (min (overlay-get company-pseudo-tooltip-overlay
   3685                                               'company-height)
   3686                                  company-candidates-length))))
   3687        (cond ((and ovl-height
   3688                    (company--inside-tooltip-p event-col-row ovl-row ovl-height))
   3689               (company-set-selection (+ (cdr event-col-row)
   3690                                         (1- company-tooltip-offset)
   3691                                         (if (and (eq company-tooltip-offset-display 'lines)
   3692                                                  (not (zerop company-tooltip-offset)))
   3693                                             -1 0)
   3694                                         (- ovl-row)
   3695                                         (if (< ovl-height 0)
   3696                                             (- 1 ovl-height)
   3697                                           0)))
   3698               t))))))
   3699 
   3700 (defun company-pseudo-tooltip-unless-just-one-frontend (command)
   3701   "`company-pseudo-tooltip-frontend', but not shown for single candidates."
   3702   (unless (and (memq command '(post-command unhide))
   3703                (company--show-inline-p))
   3704     (company-pseudo-tooltip-frontend command)))
   3705 
   3706 (defun company-pseudo-tooltip--ujofwd-on-timer (command)
   3707   (when company-candidates
   3708     (company-pseudo-tooltip-unless-just-one-frontend-with-delay command)))
   3709 
   3710 (defun company-pseudo-tooltip-unless-just-one-frontend-with-delay (command)
   3711   "`compandy-pseudo-tooltip-frontend', but shown after a delay.
   3712 Delay is determined by `company-tooltip-idle-delay'."
   3713   (defvar company-preview-overlay)
   3714   (when (and (memq command '(pre-command hide))
   3715              company-tooltip-timer)
   3716     (cancel-timer company-tooltip-timer)
   3717     (setq company-tooltip-timer nil))
   3718   (cl-case command
   3719     (post-command
   3720      (if (or company-tooltip-timer
   3721              (overlayp company-pseudo-tooltip-overlay))
   3722          (if (not (overlayp company-preview-overlay))
   3723              (company-pseudo-tooltip-unless-just-one-frontend command)
   3724            (let (company-tooltip-timer)
   3725              (company-call-frontends 'pre-command))
   3726            (company-call-frontends 'post-command))
   3727        (setq company-tooltip-timer
   3728              (run-with-timer company-tooltip-idle-delay nil
   3729                              'company-pseudo-tooltip--ujofwd-on-timer
   3730                              'post-command))))
   3731     (unhide
   3732      (when (overlayp company-pseudo-tooltip-overlay)
   3733        (company-pseudo-tooltip-unless-just-one-frontend command)))
   3734     (t
   3735      (company-pseudo-tooltip-unless-just-one-frontend command))))
   3736 
   3737 ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3738 
   3739 (defvar-local company-preview-overlay nil)
   3740 
   3741 (defun company-preview-show-at-point (pos completion)
   3742   (company-preview-hide)
   3743 
   3744   (let* ((company-common (and company-common
   3745                               (string-prefix-p company-prefix company-common)
   3746                               company-common))
   3747          (common (company--common-or-matches completion)))
   3748     (setq completion (copy-sequence (company--pre-render completion)))
   3749     (add-face-text-property 0 (length completion) 'company-preview
   3750                             nil completion)
   3751 
   3752     (cl-loop for (beg . end) in common
   3753              do (add-face-text-property beg end 'company-preview-common
   3754                                         nil completion))
   3755 
   3756     ;; Add search string
   3757     (and (string-match (funcall company-search-regexp-function
   3758                                 company-search-string)
   3759                        completion)
   3760          (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks))
   3761            (add-face-text-property mbeg mend 'company-preview-search
   3762                                    nil completion)))
   3763 
   3764     (setq completion (if (string-prefix-p company-prefix completion
   3765                                           (eq (company-call-backend 'ignore-case)
   3766                                               'keep-prefix))
   3767                          (company-strip-prefix completion)
   3768                        completion))
   3769 
   3770     (when (string-prefix-p "\n" completion)
   3771       (setq completion (concat (propertize " " 'face 'company-preview) "\n"
   3772                                (substring completion 1))))
   3773 
   3774     (and (equal pos (point))
   3775          (not (equal completion ""))
   3776          (add-text-properties 0 1 '(cursor 1) completion))
   3777 
   3778     (let* ((beg pos)
   3779            (pto company-pseudo-tooltip-overlay)
   3780            (ptf-workaround (and
   3781                             pto
   3782                             (char-before pos)
   3783                             (eq pos (overlay-start pto)))))
   3784       ;; Try to accommodate for the pseudo-tooltip overlay,
   3785       ;; which may start at the same position if it's at eol.
   3786       (when ptf-workaround
   3787         (cl-decf beg)
   3788         (setq completion (concat (buffer-substring beg pos) completion)))
   3789 
   3790       (setq company-preview-overlay (make-overlay beg pos))
   3791 
   3792       (let ((ov company-preview-overlay))
   3793         (overlay-put ov (if ptf-workaround 'display 'after-string)
   3794                      completion)
   3795         (overlay-put ov 'window (selected-window))))))
   3796 
   3797 (defun company-preview-hide ()
   3798   (when company-preview-overlay
   3799     (delete-overlay company-preview-overlay)
   3800     (setq company-preview-overlay nil)))
   3801 
   3802 (defun company-preview-frontend (command)
   3803   "`company-mode' frontend showing the selection as if it had been inserted."
   3804   (pcase command
   3805     (`pre-command (company-preview-hide))
   3806     (`unhide
   3807      (when company-selection
   3808        (let* ((current (nth company-selection company-candidates))
   3809               (company-prefix (if (equal current company-prefix)
   3810                                   ;; Would be more accurate to compare lengths,
   3811                                   ;; but this is shorter.
   3812                                   current
   3813                                 (buffer-substring
   3814                                  (- company-point (length company-prefix))
   3815                                  (point)))))
   3816          (company-preview-show-at-point (point) current))))
   3817     (`post-command
   3818      (when company-selection
   3819        (company-preview-show-at-point (point)
   3820                                       (nth company-selection company-candidates))))
   3821     (`hide (company-preview-hide))))
   3822 
   3823 (defun company-preview-if-just-one-frontend (command)
   3824   "`company-preview-frontend', but only shown for single candidates."
   3825   (when (or (not (memq command '(post-command unhide)))
   3826             (company--show-inline-p))
   3827     (company-preview-frontend command)))
   3828 
   3829 (defun company--show-inline-p ()
   3830   (and (not (cdr company-candidates))
   3831        company-common
   3832        (not (eq t (compare-strings company-prefix nil nil
   3833                                    (car company-candidates) nil nil
   3834                                    t)))
   3835        (or (eq (company-call-backend 'ignore-case) 'keep-prefix)
   3836            (string-prefix-p company-prefix company-common))))
   3837 
   3838 (defun company-tooltip-visible-p ()
   3839   "Returns whether the tooltip is visible."
   3840   (when (overlayp company-pseudo-tooltip-overlay)
   3841     (not (overlay-get company-pseudo-tooltip-overlay 'invisible))))
   3842 
   3843 (defun company-preview-common--show-p ()
   3844   "Returns whether the preview of common can be showed or not"
   3845   (and company-common
   3846        (or (eq (company-call-backend 'ignore-case) 'keep-prefix)
   3847            (string-prefix-p company-prefix company-common))))
   3848 
   3849 (defun company-preview-common-frontend (command)
   3850   "`company-mode' frontend preview the common part of candidates."
   3851   (when (or (not (memq command '(post-command unhide)))
   3852             (company-preview-common--show-p))
   3853     (pcase command
   3854       (`pre-command (company-preview-hide))
   3855       ((or 'post-command 'unhide)
   3856        (company-preview-show-at-point (point) company-common))
   3857       (`hide (company-preview-hide)))))
   3858 
   3859 ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3860 
   3861 (defvar-local company-echo-last-msg nil)
   3862 
   3863 (defvar company-echo-timer nil)
   3864 
   3865 (defvar company-echo-delay .01)
   3866 
   3867 (defcustom company-echo-truncate-lines t
   3868   "Whether frontend messages written to the echo area should be truncated."
   3869   :type 'boolean
   3870   :package-version '(company . "0.9.3"))
   3871 
   3872 (defun company-echo-show (&optional getter)
   3873   (let ((last-msg company-echo-last-msg)
   3874         (message-log-max nil)
   3875         (message-truncate-lines company-echo-truncate-lines))
   3876     (when getter
   3877       (setq company-echo-last-msg (funcall getter)))
   3878     ;; Avoid modifying the echo area if we don't have anything to say, and we
   3879     ;; didn't put the previous message there (thus there's nothing to clear),
   3880     ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=62816#20
   3881     (if (not (member company-echo-last-msg '(nil "")))
   3882         (message "%s" company-echo-last-msg)
   3883       (unless (member last-msg '(nil ""))
   3884         (message "")))))
   3885 
   3886 (defun company-echo-show-soon (&optional getter delay)
   3887   (company-echo-cancel)
   3888   (setq company-echo-timer (run-with-timer (or delay company-echo-delay)
   3889                                            nil
   3890                                            'company-echo-show getter)))
   3891 
   3892 (defun company-echo-cancel (&optional unset)
   3893   (when company-echo-timer
   3894     (cancel-timer company-echo-timer))
   3895   (when unset
   3896     (setq company-echo-timer nil)))
   3897 
   3898 (defun company-echo-format ()
   3899   (let ((selection (or company-selection 0)))
   3900     (let ((limit (window-body-width (minibuffer-window)))
   3901           (len -1)
   3902           (candidates (nthcdr selection company-candidates))
   3903           (numbered (if company-show-quick-access selection 99999))
   3904           (qa-keys-len (length company-quick-access-keys))
   3905           comp msg)
   3906 
   3907       (while candidates
   3908         (setq comp (propertize
   3909                     (company-reformat (company--clean-string (pop candidates)))
   3910                     'face
   3911                     'company-echo)
   3912               len (+ len 1 (length comp)))
   3913         (let ((beg 0)
   3914               (end (string-width (or company-common ""))))
   3915           (when (< numbered qa-keys-len)
   3916             (let ((qa-hint
   3917                    (format "%s: " (funcall
   3918                                    company-quick-access-hint-function
   3919                                    numbered))))
   3920               (setq beg (string-width qa-hint)
   3921                     end (+ beg end))
   3922               (cl-incf len beg)
   3923               (setq comp (propertize (concat qa-hint comp) 'face 'company-echo)))
   3924             (cl-incf numbered))
   3925           ;; FIXME: Add support for the `match' backend action, and thus,
   3926           ;; non-prefix matches.
   3927           (add-text-properties beg end '(face company-echo-common) comp))
   3928         (if (>= len limit)
   3929             (setq candidates nil)
   3930           (push comp msg)))
   3931 
   3932       (mapconcat 'identity (nreverse msg) " "))))
   3933 
   3934 (defun company-echo-strip-common-format ()
   3935   (let ((selection (or company-selection 0)))
   3936     (let ((limit (window-body-width (minibuffer-window)))
   3937           (len (+ (length company-prefix) 2))
   3938           (candidates (nthcdr selection company-candidates))
   3939           (numbered (if company-show-quick-access selection 99999))
   3940           (qa-keys-len (length company-quick-access-keys))
   3941           comp msg)
   3942 
   3943       (while candidates
   3944         (setq comp (company-strip-prefix (pop candidates))
   3945               len (+ len 2 (length comp)))
   3946         (when (< numbered qa-keys-len)
   3947           (let ((qa-hint (format " (%s)"
   3948                                  (funcall company-quick-access-hint-function
   3949                                           numbered))))
   3950             (setq comp (concat comp qa-hint))
   3951             (cl-incf len (string-width qa-hint)))
   3952           (cl-incf numbered))
   3953         (if (>= len limit)
   3954             (setq candidates nil)
   3955           (push (propertize comp 'face 'company-echo) msg)))
   3956 
   3957       (concat (propertize company-prefix 'face 'company-echo-common) "{"
   3958               (mapconcat 'identity (nreverse msg) ", ")
   3959               "}"))))
   3960 
   3961 (defun company-echo-hide ()
   3962   (unless (equal company-echo-last-msg "")
   3963     (setq company-echo-last-msg "")
   3964     (company-echo-show)))
   3965 
   3966 (defun company-echo-frontend (command)
   3967   "`company-mode' frontend showing the candidates in the echo area."
   3968   (pcase command
   3969     (`post-command (company-echo-show-soon 'company-echo-format 0))
   3970     (`hide (company-echo-hide))))
   3971 
   3972 (defun company-echo-strip-common-frontend (command)
   3973   "`company-mode' frontend showing the candidates in the echo area."
   3974   (pcase command
   3975     (`post-command (company-echo-show-soon 'company-echo-strip-common-format 0))
   3976     (`hide (company-echo-hide))))
   3977 
   3978 (defun company-echo-metadata-frontend (command)
   3979   "`company-mode' frontend showing the documentation in the echo area."
   3980   (pcase command
   3981     (`post-command (company-echo-show-soon 'company-fetch-metadata))
   3982     (`unhide (company-echo-show))
   3983     (`hide (company-echo-hide))))
   3984 
   3985 (provide 'company)
   3986 ;;; company.el ends here