rc

Create fix for Company bug

Just like with Company-fuzzy, this bug just popped up out of thin air on only one of my systems, and nobody seems to have this occur once, let alone know a good fix for it. Just replacing it with a useless string value did the job again.

Author
Maarten Vangeneugden
Date
Nov. 21, 2024, 10:11 a.m.
Hash
dc4f9ff3b05a165c503de2fb3a3892e844ab33b7
Parent
226ba1eacdfb635e5235eb8141724d5cb1ce2045
Modified files
company.el
init.el

company.el

4709 additions and 0 deletions.

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

init.el

7 additions and 1 deletion.

View changes Hide changes
1
1
;; Copyright © 2018-2022 Maarten Vangeneugden
2
2
;; Author: Maarten Vangeneugden <contact_me@maartenv.be>
3
3
;; URL: https://maartenv.be
4
4
;;
5
5
;; Welcome to Ghent Emacs.
6
6
;;
7
7
;; This is the configuration file for Ghent Emacs, a GNU Emacs derivative
8
8
;; developed in the city of Ghent, Belgium, by a student of Engineering
9
9
;; Informatics at Ghent University.
10
10
;;
11
11
;; License: GPLv3+
12
12
13
13
;; USAGE:
14
14
;; This configuration file uses the use-package declaration, that means the
15
15
;; settings are a bit different from what you'd normally do in a GNU Emacs
16
16
;; init.el file. Consult https://github.com/jwiegley/use-package for info on how
17
17
;; to correctly write package configuration.
18
18
19
19
;; DEBUGGING NOTE FOR COMPANY-FUZZY:
20
20
;; Do you get shit like "wrong number of arguments" that completely freezes up
21
21
;; the autocompleter? Fix it by removing the company-fuzzy.elc file from the
22
22
;; .emacs elpa layers directory, and replacing company-fuzzy.el with the
23
23
;; company-fuzzy.el file in the rc repository. Just adding this fixes a bug that
24
24
;; apparently nobody else on the internet has or has managed to figure out a fix for.
25
25
26
-
+
26
;; In the same fashion as the previous debugging note: If you get the error
+
27
;;    'company: backend company-fuzzy-all-other-backends error 
+
28
;;    "wrong type argument: stringp, 0" with args (set-min-prefix 0)',
+
29
;; then fix it by removing the company.el file from the .emacs/elpa/company directory
+
30
;; and replacing company.el with the one from the rc repository. Fixes bug that
+
31
;; (again) only I seem to have or seem to have figured out how to fix.
+
32
27
33
(eval-when-compile
28
34
  (require 'use-package))
29
35
;(require 'diminish)                ;; if you use :diminish
30
36
(require 'bind-key)                ;; if you use any :bind variant
31
37
32
38
(custom-set-variables
33
39
 ;; custom-set-variables was added by Custom.
34
40
 ;; If you edit it by hand, you could mess it up, so be careful.
35
41
 ;; Your init file should contain only one such instance.
36
42
 ;; If there is more than one, they won't work right.
37
43
 '(custom-safe-themes
38
44
   '("763bf89898a06b03f7b65fbc29857a1c292e4350246093702fdbd6c4e46e2cf0" "78e6be576f4a526d212d5f9a8798e5706990216e9be10174e3f3b015b8662e27" "d9646b131c4aa37f01f909fbdd5a9099389518eb68f25277ed19ba99adeb7279" "8b58ef2d23b6d164988a607ee153fd2fa35ee33efc394281b1028c2797ddeebb" "f9aede508e587fe21bcfc0a85e1ec7d27312d9587e686a6f5afdbb0d220eab50" "83ae405e25a0a81f2840bfe5daf481f74df0ddb687f317b5e005aa61261126e9" "c433c87bd4b64b8ba9890e8ed64597ea0f8eb0396f4c9a9e01bd20a04d15d358" "a24c5b3c12d147da6cef80938dca1223b7c7f70f2f382b26308eba014dc4833a" "732b807b0543855541743429c9979ebfb363e27ec91e82f463c91e68c772f6e3" "a2cde79e4cc8dc9a03e7d9a42fabf8928720d420034b66aecc5b665bbf05d4e9" "8aebf25556399b58091e533e455dd50a6a9cba958cc4ebb0aab175863c25b9a4" "bd7b7c5df1174796deefce5debc2d976b264585d51852c962362be83932873d9" default))
39
45
 '(inhibit-startup-screen t)
40
46
 '(package-selected-packages
41
47
   '(company-fuzzy company-yasnippet web-mode use-package srefactor spacemacs-theme spaceline solarized-theme rainbow-delimiters pretty-mode page-break-lines monokai-theme helm general evil dashboard dante company-flx company-anaconda clang-format auto-package-update auctex a))
42
48
 '(spaceline-inflation 1 t nil "Customized with use-package spaceline")
43
49
 '(spaceline-toggle-buffer-size-off nil t nil "Customized with use-package spaceline")
44
50
 '(warning-suppress-types '((comp))))
45
51
;(custom-set-faces
46
52
 ;; custom-set-faces was added by Custom.
47
53
 ;; If you edit it by hand, you could mess it up, so be careful.
48
54
 ;; Your init file should contain only one such instance.
49
55
 ;; If there is more than one, they won't work right.
50
56
 ;'(default ((((class color) (min-colors 89)) (:foreground "#ffffff" :background "#263238")))))
51
57
52
58
53
59
(add-to-list 'default-frame-alist
54
60
             '(font . "Hack-11"))
55
61
56
62
;; To get rid of those FUCKING ANNOYING BACKUP FILES FUCKING HELL DUDE
57
63
(setq backup-directory-alist '(("." . "~/.emacs.d/backup"))
58
64
  backup-by-copying t    ; Don't delink hardlinks
59
65
  version-control t      ; Use version numbers on backups
60
66
  delete-old-versions t  ; Automatically delete excess backups
61
67
  kept-new-versions 20   ; how many of the newest versions to keep
62
68
  kept-old-versions 5    ; and how many of the old
63
69
  )
64
70
;; And yes I copied it from SO, suck it: https://stackoverflow.com/questions/2680389/how-to-remove-all-files-ending-with-made-by-emacs
65
71
66
72
;; Disables the use of tabs, replaces them with spaces
67
73
(setq-default indent-tabs-mode nil)
68
74
69
75
;; Activate UTF-8 throughout Ghent Emacs
70
76
(prefer-coding-system 'utf-8)
71
77
(set-default-coding-systems 'utf-8)
72
78
(set-terminal-coding-system 'utf-8)
73
79
(set-keyboard-coding-system 'utf-8)
74
80
(setq x-select-request-type '(UTF8_STRING COMPOUND_TEXT TEXT STRING))
75
81
76
82
;; Line numbering config
77
83
(global-display-line-numbers-mode)
78
84
(setq display-line-numbers-mode t)
79
85
(setq display-line-numbers-widen t)
80
86
(setq display-line-numbers-type 'relative)
81
87
(setq display-line-numbers-current-absolute t)
82
88
83
89
(setq mouse-wheel-scroll-amount '(1 ((shift) . 1)))
84
90
(setq scroll-step 1)
85
91
(setq scroll-margin 10) ;; Keeps 10 lines above and down always visible if still left
86
92
87
93
;; Enable line breaks in all modes at column 80
88
94
(setq-default auto-fill-function 'do-auto-fill)
89
95
(setq-default fill-column 80)
90
96
91
97
(setq ring-bell-function 'ignore) ;; Disables the FUCKING ANNOYING BEEPS HOLY SHIT
92
98
93
99
;; Setup packages
94
100
;(package-initialize)
95
101
(require 'package)
96
102
(setq package-enable-at-startup nil)
97
103
(add-to-list 'package-archives '("org" . "https://orgmode.org/elpa/"))
98
104
(add-to-list 'package-archives '("melpa" . "http://melpa.org/packages/"))
99
105
(unless (package-installed-p 'use-package)
100
106
  (package-refresh-contents)
101
107
(package-install 'use-package))
102
108
103
109
104
110
105
111
106
112
;; Next two lines allow foregoing :ensure t on all packages
107
113
;; :ensure t simply makes sure that, if a package isn't installed on this
108
114
;; machine, it's automatically fetched and installed.
109
115
;; This doesn't keep packages up-to-date, cfr. auto-package-update for that
110
116
(require 'use-package-ensure)
111
117
(setq use-package-always-ensure t)
112
118
113
119
;; Package for automatic updating of all the other packages
114
120
(use-package auto-package-update
115
121
  :config
116
122
  (setq auto-package-update-delete-old-versions t)
117
123
  (setq auto-package-update-hide-results t)
118
124
  (auto-package-update-maybe))
119
125
120
126
;; Easier keybindings so we can do more lazy loading
121
127
(use-package general
122
128
  :config
123
129
  (general-create-definer my-leader-def
124
130
	;; :prefix my-leader
125
131
	:prefix "SPC")
126
132
  (general-create-definer local-leader-def
127
133
	;; :prefix local-leader
128
134
	:prefix ","))
129
135
130
136
(use-package dashboard
131
137
  :init
132
138
  (setq dashboard-banner-logo-title "") ; It's nicer to just not have a title text.
133
139
  (setq dashboard-startup-banner "~/ghent-emacs.png")
134
140
  :config
135
141
  (dashboard-setup-startup-hook))
136
142
137
143
;; AUCTeX configuration
138
144
;; Partly inspired by https://piotr.is/2010/emacs-as-the-ultimate-latex-editor/
139
145
;;;;(use-package auctex
140
146
  ;;:init
141
147
  ;;(setq TeX-auto-save t)
142
148
  ;;(setq TeX-parse-self t)
143
149
  ;;(setq Tex-save-query nil)
144
150
  ;;)
145
151
146
152
;; Updates all packages automatically
147
153
(use-package auto-package-update
148
154
  :config
149
155
  (setq auto-package-update-delete-old-versions t)
150
156
  (setq auto-package-update-hide-results t)
151
157
  (auto-package-update-maybe))
152
158
153
159
;; UI settings
154
160
(tool-bar-mode -1)
155
161
(menu-bar-mode -1)
156
162
(toggle-scroll-bar -1)
157
163
158
164
;; Tabs and width
159
165
(setq-default tab-width 4)
160
166
(setq-default c-basic-offset 4)
161
167
162
168
(use-package spaceline
163
169
    :init
164
170
    (setq frame-char-height 35)
165
171
    (setq powerline-height 35)
166
172
    :custom
167
173
     (spaceline-toggle-buffer-size-off)
168
174
     ;(setq powerline-height 21)
169
175
  (spaceline-inflation 1)
170
176
  (powerline-default-separator 'slant)
171
177
  :config
172
178
  (spaceline-spacemacs-theme)
173
179
  (setq spaceline-highlight-face-func 'spaceline-highlight-face-evil-state)) 
174
180
175
181
176
182
(use-package monokai-theme
177
183
    :config
178
184
    (load-theme 'monokai t)
179
185
    (setq monokai-variable-pitch-mode t))
180
186
;; When using solarized as theme, put in :config
181
187
;; (setq x-underline-at-descent-line t)
182
188
;; Which will block an ugly line being drawn trhough the modeline.
183
189
184
190
;(add-hook 'org-mode-hook '(lambda () (setq fill-column 80)))
185
191
;(add-hook 'org-mode-hook 'auto-fill-mode)
186
192
;; (Programming) languages
187
193
188
194
189
195
190
196
(use-package dante
191
197
  :after haskell-mode
192
198
  :commands 'dante-mode
193
199
  :init
194
200
  (add-hook 'haskell-mode-hook 'dante-mode)
195
201
  (add-hook 'haskell-mode-hook 'flycheck-mode)
196
202
  (add-hook 'haskell-mode-hook '
197
203
            (lambda () (modify-syntax-entry ?_ "w")))
198
204
  )
199
205
200
206
    
201
207
;; HTML/CSS/Django
202
208
(use-package web-mode
203
209
  :mode "\\.html?\\.djhtml\\'"
204
210
  :init
205
211
  (add-to-list 'auto-mode-alist '("\\.djhtml\\'" . web-mode))
206
212
  (setq web-mode-markup-indent-offset 4)
207
213
  (setq web-mode-css-indent-offset 4)
208
214
  (setq web-mode-code-indent-offset 4)
209
215
  ;(setq web-mode-engines-alist
210
216
;	'(("django"    . "\\.html\\"))) ;; FIXME this doesn't work yet. IDK why.
211
217
  :custom ;; Next lines disable all the automatic completion stuff that I didn't explicitely ask for
212
218
  (web-mode-enable-auto-pairing nil)
213
219
  (web-mode-enable-auto-closing nil)
214
220
  (web-mode-enable-auto-expanding nil)
215
221
  (web-mode-enable-auto-opening nil)
216
222
  (web-mode-enable-auto-quoting nil))
217
223
218
224
219
225
(use-package company
220
226
 :hook (after-init . global-company-mode)
221
227
 :init
222
228
 (company-tng-configure-default)  ; Use <TAB> to scroll in completion options
223
229
 (setq company-minimum-prefix-length 2)
224
230
 (setq company-idle-delay 0.0))
225
231
226
232
227
233
(use-package company-fuzzy
228
234
  :hook (company-mode . company-fuzzy-mode)
229
235
  :init
230
236
  (setq company-fuzzy-sorting-backend 'flx
231
237
        company-fuzzy-reset-selection t
232
238
        company-fuzzy-prefix-on-top nil
233
239
        company-fuzzy-history-backends '(company-yasnippet)
234
240
        company-fuzzy-trigger-symbols '("." "->" "<" "\"" "'" "@")))
235
241
236
242
(global-company-fuzzy-mode 1)
237
243
238
244
(use-package clang-format
239
245
  :general
240
246
  (local-leader-def
241
247
   :states 'normal
242
248
   :modes '(c-mode-map c++-mode-map)
243
249
   "b" '(:ignore t :which-key "clang")
244
250
   "bf" 'clang-format-buffer)
245
251
  :init
246
252
  (setq-default clang-format-style "{BasedOnStyle: llvm, IndentWidth: 4}"))
247
253
248
254
;; eViL-mode
249
255
(use-package evil
250
256
  :hook (after-init . evil-mode)
251
257
  :bind (:map evil-normal-state-map ;; Scrolls over lines correctly
252
258
              ("j" . evil-next-visual-line)
253
259
              ("k" . evil-previous-visual-line))
254
260
  :general
255
261
  (my-leader-def
256
262
	:states 'normal
257
263
    "b" '(:ignore t :which-key "buffer")
258
264
    "g" '(:ignore t :which-key "magit")
259
265
    "f" '(:ignore t :which-key "files")
260
266
	"bk" 'kill-this-buffer
261
267
	"bd" 'kill-other-buffers
262
268
	"bh" 'switch-to-home-buffer
263
269
	"br" 'revert-buffer
264
270
	"h" 'split-window-vertically
265
271
	"v" 'split-window-horizontally)
266
272
  (local-leader-def
267
273
	:states 'normal
268
274
    ;; General lang options
269
275
	"c" 'compile)
270
276
  :init
271
277
  (setq evil-find-skip-newlines t) ;; Allows f/F/t/T to search beyond CR/LF
272
278
  (setq evil-undo-system 'undo-redo)  ;; Just uses standard undo-redo behaviour
273
279
  ;; a normal human expects
274
280
  (setq evil-want-C-u-scroll t)) ;; Activates c-u scroll to above.
275
281
276
282
;; About smooth-scrolling: I'd normally just use some variables for scrolling
277
283
;; but they all fail with org-mode. This package fixes everything that's wrong for me.
278
284
;(use-package smooth-scrolling
279
285
   ;:config
280
286
   ;(smooth-scrolling-mode 1))
281
287
282
288
(use-package org
283
289
  :pin "org"
284
290
  ; FIXME This causes some errors with bind-keys or what have you. Commented
285
291
  ; until it is fixed.
286
292
  ;:bind (:bind-keymap
287
293
  ;        ("C-c x" . org-todo-state-map)
288
294
  ;       :map org-todo-state-map
289
295
  ;        ("x" . #'(lambda nil (interactive) (org-todo "CANCELLED")))
290
296
  ;        ("d" . #'(lambda nil (interactive) (org-todo "DONE")))
291
297
  ;        ("f" . #'(lambda nil (interactive) (org-todo "DEFERRED")))
292
298
  ;        ("l" . #'(lambda nil (interactive) (org-todo "DELEGATED")))
293
299
  ;        ("s" . #'(lambda nil (interactive) (org-todo "STARTED")))
294
300
  ;        ("w" . #'(lambda nil (interactive) (org-todo "WAITING"))))
295
301
;         :map org-mode-map
296
302
;          ("C-c x" . org-todo-state-map))
297
303
   :init
298
304
  (define-key mode-specific-map [?a] 'org-agenda)
299
305
  :custom
300
306
  ;; Because I use XeLaTeX (it's objectively better), some variables need to be
301
307
  ;; set so org-mode knows what to call.
302
308
303
309
  ;; Okay, so you cán export asynchronous so compiling your PDF doesn't lock up
304
310
  ;; the editor completely, but for one reason or another, you MUST set the
305
311
  ;; async-debug to nil. Otherwise it will constantly "exit abnormally" without
306
312
  ;; reason. This fixes it, who knows why.
307
313
  (org-export-async-debug nil)
308
314
  
309
315
  (org-latex-compiler 'xelatex)  ; Makes sure the XeLaTeX compiler is used
310
316
  
311
317
  ; Tells Org to use dvisvgm because dvipng does not support XeLaTeX's output format
312
318
  (org-preview-latex-default-process 'dvisvgm)
313
319
  
314
320
  ; This edits the preview process so it works correctly with XeLaTeX.
315
321
  ; Changes: 
316
322
  ; - "latex" to "xelatex" 
317
323
  ; - Added the "-no-pdf" flag so it prints an XDV file instead of PDF.
318
324
  ; - change input type from dvi to xdv
319
325
  ; - Only leave the dvisvgm option because I don't need the others
320
326
  (org-preview-latex-process-alist
321
327
   (quote
322
328
    ((dvisvgm :programs
323
329
              ("xelatex" "dvisvgm")
324
330
              :description "dvi > svg" :message "you need to install the programs: xelatex and dvisvgm." :use-xcolor t :image-input-type "xdv" :image-output-type "svg" :image-size-adjust
325
331
              (1.7 . 1.5)
326
332
              :latex-compiler
327
333
              ("xelatex -interaction nonstopmode -no-pdf -output-directory %o %f")
328
334
              :image-converter
329
335
              ("dvisvgm %f -n -b min -c %S -o %O")))))
330
336
331
337
  ;; Sets the formatting options. I only changed :scale to 1.6, but I don't know
332
338
  ;; how to change only thát, so for now I'm configuring the entire variable
333
339
  (org-format-latex-options (quote
334
340
   (:foreground default :background default :scale 1.6 :html-foreground "Black" :html-background "Transparent" :html-scale 1.0 :matchers
335
341
             ("begin" "$1" "$" "$$" "\\(" "\\["))))
336
342
    
337
343
  ;; Sets the directory in which the preview fragments are stored to the /tmp
338
344
  ;; folder. Otherwise it clutters up the folder in which the source resides
339
345
  ;; with what are essentially cache files.
340
346
  (org-preview-latex-image-directory "/tmp/ltximg/")
341
347
  
342
348
  ;; Following customizations are in regard to org-agenda configuration.
343
349
  (org-agenda-files (quote ("~/shared/planning/planning.org")))
344
350
  (org-default-notes-file "~/shared/planning/notes.org")
345
351
  (org-agenda-span 62)
346
352
  (org-deadline-warning-days 14)
347
353
  (org-agenda-show-all-dates t)
348
354
  (org-agenda-skip-deadline-if-done t)
349
355
  (org-agenda-skip-scheduled-if-done t)
350
356
  (org-agenda-start-on-weekday nil)
351
357
  (org-reverse-note-order t)
352
358
  (org-fast-tag-selection-single-key (quote expert))
353
359
  (org-agenda-custom-commands
354
360
    (quote (("d" todo "DELEGATED" nil)
355
361
      ("c" todo "DONE|DEFERRED|CANCELED" nil)
356
362
      ("w" todo "WAITING" nil)
357
363
      ("W" agenda "" ((org-agenda-ndays 21)))
358
364
      ("A" agenda ""
359
365
        ((org-agenda-skip-function
360
366
          (lambda nil
361
367
      (org-agenda-skip-entry-if (quote notregexp) "\\=.*\\[#A\\]")))
362
368
        (org-agenda-ndays 1)
363
369
        (org-agenda-overriding-header "Today's Priority #A tasks: ")))
364
370
      ("u" alltodo ""
365
371
        ((org-agenda-skip-function
366
372
          (lambda nil
367
373
      (org-agenda-skip-entry-if (quote scheduled) (quote deadline)
368
374
              (quote regexp) "\n]+>")))
369
375
        (org-agenda-overriding-header "Unscheduled TODO entries: "))))))
370
376
  (org-capture-store-without-prompt t)
371
377
  (org-capture-templates
372
378
    (quote ((116 "* TODO %?\n  %u" "~/Repositories/private/org/planning.org" "Tasks")
373
379
      (110 "* %u %?" "~/Repositories/private/org/notes.org" "Notes"))))
374
380
  (capture-annotation-functions (quote (org-capture-annotation)))
375
381
  (capture-handler-functions (quote (org-capture-handler))))
376
382
377
383
  ;:general
378
384
  ;(local-leader-def
379
385
  ;  :states 'normal
380
386
  ;  :keymaps 'org-mode-map
381
387
;	"e" 'org-export-dispatch
382
388
;	"x" 'org-table-export
383
389
;	"." 'org-time-stamp
384
390
;	"t" 'org-twbs-export-to-html
385
391
;	"s" 'org-schedule
386
392
;	"d" 'org-deadline
387
393
;	"'" 'org-edit-special)
388
394
;  :config
389
395
;  ;; log todo items with timestamp
390
396
;  (setq org-log-done 'time))
391
397
392
398
(use-package helm
393
399
  :hook (after-init . helm-mode)
394
400
  :commands (helm-autoresize-mode)
395
401
  :init
396
402
  ;; (defvar helm-google-suggest-use-curl-p)
397
403
  (defvar helm-ff-search-library-in-sexp)
398
404
  (defvar helm-echo-input-in-header-line)
399
405
  (defvar helm-ff-file-name-history-use-recentf)
400
406
  :general
401
407
  (general-define-key
402
408
   "M-x" 'helm-M-x
403
409
   "M-:" 'helm-eval-expression
404
410
   "C-c h" 'helm-command-prefix)
405
411
  (general-define-key
406
412
   :keymaps 'helm-map
407
413
   "<tab>" 'helm-execute-persistent-action
408
414
   "C-i" 'helm-execute-persistent-action
409
415
   "C-z" 'helm-select-action)
410
416
  (my-leader-def
411
417
	:states 'normal
412
418
	"bb" 'helm-buffers-list
413
419
	"ff" 'helm-find-files
414
420
	"p" 'helm-show-kill-ring)
415
421
  :config
416
422
  (setq helm-split-window-inside-p           t ; open helm buffer inside current window, not occupy whole other window
417
423
	helm-move-to-line-cycle-in-source     t ; move to end or beginning of source when reaching top or bottom of source.
418
424
	helm-ff-search-library-in-sexp        t ; search for library in `require' and `declare-function' sexp.
419
425
	helm-scroll-amount                    8 ; scroll 8 lines other window using m-<next>/m-<prior>
420
426
	helm-ff-file-name-history-use-recentf t
421
427
	helm-echo-input-in-header-line t)
422
428
423
429
  ;; hide some autogenerated files from helm
424
430
  (setq helm-ff-skip-boring-files t)
425
431
  ;; (add-to-list 'helm-boring-file-regexp-list "\\~$")
426
432
  
427
433
  (setq helm-autoresize-max-height 0)
428
434
  (setq helm-autoresize-min-height 20)
429
435
  (helm-autoresize-mode 1))
430
436
431
437
432
438
(use-package rainbow-delimiters
433
439
  :hook (prog-mode . rainbow-delimiters-mode))
434
440
435
441
;; Settings for having an LaTeX beamer class export tool
436
442
(unless (boundp 'org-export-latex-classes)
437
443
(setq org-export-latex-classes nil))
438
444
(add-to-list 'org-export-latex-classes
439
445
;; beamer class, for presentations
440
446
'("beamer"
441
447
    "\\documentclass[11pt]{beamer}\n
442
448
    \\mode<{{{beamermode}}}>\n
443
449
    \\usetheme{{{{beamertheme}}}}\n
444
450
    \\usecolortheme{{{{beamercolortheme}}}}\n
445
451
    \\beamertemplateballitem\n
446
452
    \\setbeameroption{show notes}
447
453
    \\usepackage[utf8]{inputenc}\n
448
454
    \\usepackage[T1]{fontenc}\n
449
455
    \\usepackage{hyperref}\n
450
456
    \\usepackage{color}
451
457
    \\usepackage{listings}
452
458
    \\lstset{numbers=none,language=[ISO]C++,tabsize=4,
453
459
frame=single,
454
460
basicstyle=\\small,
455
461
showspaces=false,showstringspaces=false,
456
462
showtabs=false,
457
463
keywordstyle=\\color{blue}\\bfseries,
458
464
commentstyle=\\color{red},
459
465
}\n
460
466
    \\usepackage{verbatim}\n
461
467
    \\institute{{{{beamerinstitute}}}}\n          
462
468
    \\subject{{{{beamersubject}}}}\n"
463
469
464
470
    ("\\section{%s}" . "\\section*{%s}")
465
471
466
472
    ("\\begin{frame}[fragile]\\frametitle{%s}"
467
473
    "\\end{frame}"
468
474
    "\\begin{frame}[fragile]\\frametitle{%s}"
469
475
    "\\end{frame}")))
470
476
471
477
;; Adds a letter class, for formal letters
472
478
473
479
(add-to-list 'org-export-latex-classes
474
480
475
481
'("letter"
476
482
    "\\documentclass[11pt]{letter}\n
477
483
    \\usepackage[utf8]{inputenc}\n
478
484
    \\usepackage[T1]{fontenc}\n
479
485
    \\usepackage{color}"
480
486
481
487
    ("\\section{%s}" . "\\section*{%s}")
482
488
    ("\\subsection{%s}" . "\\subsection*{%s}")
483
489
    ("\\subsubsection{%s}" . "\\subsubsection*{%s}")
484
490
    ("\\paragraph{%s}" . "\\paragraph*{%s}")
485
491
    ("\\subparagraph{%s}" . "\\subparagraph*{%s}")))
486
492
487
493
488
494
(custom-set-faces
489
495
 ;; custom-set-faces was added by Custom.
490
496
 ;; If you edit it by hand, you could mess it up, so be careful.
491
497
 ;; Your init file should contain only one such instance.
492
498
 ;; If there is more than one, they won't work right.
493
499
 '(default ((t (:background nil)))))
494
500
495
501
496
502
;; This is to fix the retarded scrolling behaviour in Emacs as much as possible:
497
503
(setq redisplay-dont-pause t
498
504
  scroll-margin 1
499
505
  scroll-step 1
500
506
  scroll-conservatively 10000
501
507
  scroll-preserve-screen-position 1)
502
508
;; Stops Emacs from accelerating my scroll:
503
509
(setq mouse-wheel-progressive-speed nil)
504
510
;; Makes scrolling do 5 lines at a time, otherwise it's pretty slow
505
511
(setq mouse-wheel-scroll-amount '(2))
506
512