mirror of https://github.com/Chizi123/.emacs.d.git

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