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