-
-
Notifications
You must be signed in to change notification settings - Fork 23
/
Copy pathcape.el
1291 lines (1174 loc) · 52.8 KB
/
cape.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; cape.el --- Completion At Point Extensions -*- lexical-binding: t -*-
;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
;; Author: Daniel Mendler <[email protected]>
;; Maintainer: Daniel Mendler <[email protected]>
;; Created: 2021
;; Version: 1.8
;; Package-Requires: ((emacs "28.1") (compat "30"))
;; URL: https://github.com/minad/cape
;; Keywords: abbrev, convenience, matching, completion, text
;; This file is part of GNU Emacs.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Let your completions fly! This package provides additional completion
;; backends in the form of Capfs (completion-at-point-functions).
;;
;; `cape-abbrev': Complete abbreviation (add-global-abbrev, add-mode-abbrev).
;; `cape-dabbrev': Complete word from current buffers.
;; `cape-dict': Complete word from dictionary file.
;; `cape-elisp-block': Complete Elisp in Org or Markdown code block.
;; `cape-elisp-symbol': Complete Elisp symbol.
;; `cape-emoji': Complete Emoji.
;; `cape-file': Complete file name.
;; `cape-history': Complete from Eshell, Comint or minibuffer history.
;; `cape-keyword': Complete programming language keyword.
;; `cape-line': Complete entire line from file.
;; `cape-rfc1345': Complete Unicode char using RFC 1345 mnemonics.
;; `cape-sgml': Complete Unicode char from SGML entity, e.g., &alpha.
;; `cape-tex': Complete Unicode char from TeX command, e.g. \hbar.
;;; Code:
(require 'compat)
(eval-when-compile
(require 'cl-lib)
(require 'subr-x))
;;;; Customization
(defgroup cape nil
"Completion At Point Extensions."
:link '(info-link :tag "Info Manual" "(cape)")
:link '(url-link :tag "Website" "https://github.com/minad/cape")
:link '(emacs-library-link :tag "Library Source" "cape.el")
:group 'convenience
:group 'tools
:group 'matching
:prefix "cape-")
(defcustom cape-dict-limit 100
"Maximal number of completion candidates returned by `cape-dict'."
:type '(choice (const nil) natnum))
(defcustom cape-dict-file "/usr/share/dict/words"
"Path to dictionary word list file.
This variable can also be a list of paths or
a function returning a single or more paths."
:type '(choice string (repeat string) function))
(defcustom cape-dict-case-replace 'case-replace
"Preserve case of input.
See `dabbrev-case-replace' for details."
:type '(choice (const :tag "off" nil)
(const :tag "use `case-replace'" case-replace)
(other :tag "on" t)))
(defcustom cape-dict-case-fold 'case-fold-search
"Case fold search during search.
See `dabbrev-case-fold-search' for details."
:type '(choice (const :tag "off" nil)
(const :tag "use `case-fold-search'" case-fold-search)
(other :tag "on" t)))
(defcustom cape-dabbrev-min-length 4
"Minimum length of Dabbrev expansions.
This setting ensures that words which are too short
are not offered as completion candidates, such that
auto completion does not pop up too aggressively."
:type 'natnum)
(defcustom cape-dabbrev-check-other-buffers t
"Buffers to check for Dabbrev.
If t, check all other buffers, subject to Dabbrev ignore rules.
If a function, only search the buffers returned by this function.
Any other non-nil value only checks some other buffers, as per
`dabbrev-select-buffers-function'."
:type `(choice (const :tag "off" nil)
(const :tag "same-mode buffers" ,#'cape--buffers-major-mode)
(function :tag "function")
(const :tag "some" some)
(other :tag "all" t)))
(defcustom cape-file-directory nil
"Base directory used by `cape-file."
:type '(choice (const nil) string function))
(defcustom cape-file-prefix "file:"
"File completion trigger prefixes.
The value can be a string or a list of strings. The default
`file:' is the prefix of Org file links which work in arbitrary
buffers via `org-open-at-point-global'."
:type '(choice string (repeat string)))
(defcustom cape-file-directory-must-exist t
"The parent directory must exist for file completion."
:type 'boolean)
(defcustom cape-line-buffer-function #'cape--buffers-major-mode
"Function which returns list of buffers.
The buffers are scanned for completion candidates by `cape-line'."
:type '(choice (const :tag "Current buffer" current-buffer)
(const :tag "All buffers" buffer-list)
(const :tag "Buffers with same major mode" cape--buffers-major-mode)
(function :tag "Custom function")))
(defcustom cape-elisp-symbol-wrapper
'((org-mode ?~ ?~)
(markdown-mode ?` ?`)
(emacs-lisp-mode ?` ?')
(rst-mode "``" "``")
(log-edit-mode "`" "'")
(change-log-mode "`" "'")
(message-mode "`" "'")
(rcirc-mode "`" "'"))
"Wrapper characters for symbols."
:type '(alist :key-type symbol :value-type (list (choice character string)
(choice character string))))
;;;; Helpers
(defun cape--case-fold-p (fold)
"Return non-nil if case folding is enabled for FOLD."
(if (eq fold 'case-fold-search) case-fold-search fold))
(defun cape--case-replace-list (flag input strs)
"Replace case of STRS depending on INPUT and FLAG."
(if (and (if (eq flag 'case-replace) case-replace flag)
(let (case-fold-search) (string-match-p "\\`[[:upper:]]" input)))
(mapcar (apply-partially #'cape--case-replace flag input) strs)
strs))
(defun cape--case-replace (flag input str)
"Replace case of STR depending on INPUT and FLAG."
(or (and (if (eq flag 'case-replace) case-replace flag)
(string-prefix-p input str t)
(let (case-fold-search) (string-match-p "\\`[[:upper:]]" input))
(save-match-data
;; Ensure that single character uppercase input does not lead to an
;; all uppercase result.
(when (and (= (length input) 1) (> (length str) 1))
(setq input (concat input (substring str 1 2))))
(and (string-match input input)
(replace-match str nil nil input))))
str))
(defun cape--separator-p (str)
"Return non-nil if input STR has a separator character.
Separator characters are used by completion styles like Orderless
to split filter words. In Corfu, the separator is configurable
via the variable `corfu-separator'."
(string-search (string ;; Support `corfu-separator' and Orderless
(or (and (bound-and-true-p corfu-mode)
(bound-and-true-p corfu-separator))
?\s))
str))
(defmacro cape--silent (&rest body)
"Silence BODY."
(declare (indent 0))
`(cl-letf ((inhibit-message t)
(message-log-max nil)
((symbol-function #'minibuffer-message) #'ignore))
(ignore-errors ,@body)))
(defun cape--bounds (thing)
"Return bounds of THING."
(or (bounds-of-thing-at-point thing) (cons (point) (point))))
(defmacro cape--wrapped-table (wrap body)
"Create wrapped completion table, handle `completion--unquote'.
WRAP is the wrapper function.
BODY is the wrapping expression."
(declare (indent 1))
`(lambda (str pred action)
(,@body
(let ((result (complete-with-action action table str pred)))
(when (and (eq action 'completion--unquote) (functionp (cadr result)))
(cl-callf ,wrap (cadr result)))
result))))
(defun cape--accept-all-table (table)
"Create completion TABLE which accepts all input."
(cape--wrapped-table cape--accept-all-table
(or (eq action 'lambda))))
(defun cape--passthrough-table (table)
"Create completion TABLE disabling any filtering."
(cape--wrapped-table cape--passthrough-table
(let (completion-ignore-case completion-regexp-list (_ (setq str ""))))))
(defun cape--noninterruptible-table (table)
"Create non-interruptible completion TABLE."
(cape--wrapped-table cape--noninterruptible-table
(let (throw-on-input))))
(defun cape--silent-table (table)
"Create a new completion TABLE which is silent (no messages, no errors)."
(cape--wrapped-table cape--silent-table
(cape--silent)))
(defun cape--nonessential-table (table)
"Mark completion TABLE as `non-essential'."
(let ((dir default-directory))
(cape--wrapped-table cape--nonessential-table
(let ((default-directory dir)
(non-essential t))))))
(defvar cape--debug-length 5
"Length of printed lists in `cape--debug-print'.")
(defvar cape--debug-id 0
"Completion table identifier.")
(defun cape--debug-message (&rest msg)
"Print debug MSG."
(let ((inhibit-message t))
(apply #'message msg)))
(defun cape--debug-print (obj &optional full)
"Print OBJ as string, truncate lists if FULL is nil."
(cond
((symbolp obj) (symbol-name obj))
((functionp obj) "#<function>")
((proper-list-p obj)
(concat
"("
(string-join
(mapcar #'cape--debug-print
(if full obj (take cape--debug-length obj)))
" ")
(if (and (not full) (length> obj cape--debug-length)) " ...)" ")")))
(t (let ((print-level 2))
(prin1-to-string obj)))))
(defun cape--debug-table (table name beg end)
"Create completion TABLE with debug messages.
NAME is the name of the Capf, BEG and END are the input markers."
(lambda (str pred action)
(let ((result (complete-with-action action table str pred)))
(if (and (eq action 'completion--unquote) (functionp (cadr result)))
;; See `cape--wrapped-table'
(cl-callf cape--debug-table (cadr result) name beg end)
(cape--debug-message
"%s(action=%S input=%s:%s:%S prefix=%S ignore-case=%S%s%s) => %s"
name
(pcase action
('nil 'try)
('t 'all)
('lambda 'test)
(_ action))
(+ beg 0) (+ end 0) (buffer-substring-no-properties beg end)
str completion-ignore-case
(if completion-regexp-list
(format " regexp=%s" (cape--debug-print completion-regexp-list t))
"")
(if pred
(format " predicate=%s" (cape--debug-print pred))
"")
(cape--debug-print result)))
result)))
(defun cape--dynamic-table (beg end fun)
"Create dynamic completion table from FUN with caching.
BEG and END are the input bounds. FUN is the function which
computes the candidates. FUN must return a pair of a predicate
function function and the list of candidates. The predicate is
passed new input and must return non-nil if the candidates are
still valid.
It is only necessary to use this function if the set of
candidates is computed dynamically based on the input and not
statically determined. The behavior is similar but slightly
different to `completion-table-dynamic'.
The difference to the builtins `completion-table-dynamic' and
`completion-table-with-cache' is that this function does not use
the prefix argument of the completion table to compute the
candidates. Instead it uses the input in the buffer between BEG
and END to FUN to compute the candidates. This way the dynamic
candidate computation is compatible with non-prefix completion
styles like `substring' or `orderless', which pass the empty
string as first argument to the completion table."
(let ((beg (copy-marker beg))
(end (copy-marker end t))
valid table)
(lambda (str pred action)
;; Bail out early for `metadata' and `boundaries'. This is a pointless
;; move because of caching, but we do it anyway in the hope that the
;; profiler report looks less confusing, since the weight of the expensive
;; FUN computation is moved to the `all-completions' action. Computing
;; `all-completions' must surely be most expensive, so nobody will suspect
;; a thing.
(unless (or (eq action 'metadata) (eq (car-safe action) 'boundaries))
(let ((input (buffer-substring-no-properties beg end)))
(unless (and valid
(or (cape--separator-p input)
(funcall valid input)))
(let* (;; Reset in case `all-completions' is used inside FUN
completion-ignore-case completion-regexp-list
;; Retrieve new state by calling FUN
(new (and (< beg end) (funcall fun input)))
;; No interrupt during state update
throw-on-input)
(setq valid (car new) table (cdr new)))))
(complete-with-action action table str pred)))))
;;;; Capfs
;;;;; cape-history
(declare-function ring-elements "ring")
(declare-function eshell-bol "eshell")
(declare-function comint-line-beginning-position "comint")
(defvar eshell-history-ring)
(defvar comint-input-ring)
(defvar cape--history-properties
(list :company-kind (lambda (_) 'text)
:exclusive 'no
:display-sort-function #'identity
:cycle-sort-function #'identity
:category 'cape-history)
"Completion extra properties for `cape-history'.")
;;;###autoload
(defun cape-history (&optional interactive)
"Complete from Eshell, Comint or minibuffer history.
See also `consult-history' for a more flexible variant based on
`completing-read'. If INTERACTIVE is nil the function acts like a Capf."
(interactive (list t))
(if interactive
(cape-interactive #'cape-history)
(let (history bol)
(cond
((derived-mode-p 'eshell-mode)
(setq history eshell-history-ring
bol (static-if (< emacs-major-version 30)
(save-excursion (eshell-bol) (point))
(line-beginning-position))))
((derived-mode-p 'comint-mode)
(setq history comint-input-ring
bol (comint-line-beginning-position)))
((and (minibufferp) (not (eq minibuffer-history-variable t)))
(setq history (symbol-value minibuffer-history-variable)
bol (line-beginning-position))))
(when (ring-p history)
(setq history (ring-elements history)))
(when history
`(,bol ,(point) ,history ,@cape--history-properties)))))
;;;;; cape-file
(defvar comint-unquote-function)
(defvar comint-requote-function)
(defvar cape--file-properties
(list :annotation-function (lambda (s) (if (string-suffix-p "/" s) " Dir" " File"))
:company-kind (lambda (s) (if (string-suffix-p "/" s) 'folder 'file))
:exclusive 'no
:category 'file)
"Completion extra properties for `cape-file'.")
;;;###autoload
(defun cape-file (&optional interactive)
"Complete file name at point.
See the user option `cape-file-directory-must-exist'.
If INTERACTIVE is nil the function acts like a Capf."
(interactive (list t))
(if interactive
(cape-interactive '(cape-file-directory-must-exist) #'cape-file)
(pcase-let* ((default-directory (pcase cape-file-directory
('nil default-directory)
((pred stringp) cape-file-directory)
(_ (funcall cape-file-directory))))
(prefix (and cape-file-prefix
(looking-back
(concat
(regexp-opt (ensure-list cape-file-prefix) t)
"[^ \n\t]*")
(pos-bol))
(match-end 1)))
(`(,beg . ,end) (if prefix
(cons prefix (point))
(cape--bounds 'filename)))
(non-essential t)
(file (buffer-substring-no-properties beg end)))
(when (or prefix
(not cape-file-directory-must-exist)
(and (string-search "/" file)
(file-exists-p (file-name-directory file))))
(unless (boundp 'comint-unquote-function)
(require 'comint))
`( ,beg ,end
,(cape--nonessential-table
(completion-table-with-quoting
#'read-file-name-internal
comint-unquote-function
comint-requote-function))
,@(when (or prefix (string-match-p "./" file))
'(:company-prefix-length t))
,@cape--file-properties)))))
;;;;; cape-elisp-symbol
(autoload 'elisp--company-kind "elisp-mode")
(autoload 'elisp--company-doc-buffer "elisp-mode")
(autoload 'elisp--company-doc-string "elisp-mode")
(autoload 'elisp--company-location "elisp-mode")
(defvar cape--elisp-symbol-properties
(list :annotation-function #'cape--elisp-symbol-annotation
:exit-function #'cape--elisp-symbol-exit
:predicate #'cape--elisp-symbol-predicate
:company-kind #'elisp--company-kind
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
:company-location #'elisp--company-location
:exclusive 'no
:category 'symbol)
"Completion extra properties for `cape-elisp-symbol'.")
(defun cape--elisp-symbol-predicate (sym)
"Return t if SYM is bound, fbound or propertized."
(or (fboundp sym) (boundp sym) (symbol-plist sym)))
(defun cape--elisp-symbol-exit (sym status)
"Wrap symbol SYM with `cape-elisp-symbol-wrapper' buffers.
STATUS is the exit status."
(when-let (((not (eq status 'exact)))
(c (cl-loop for (m . c) in cape-elisp-symbol-wrapper
if (derived-mode-p m) return c))
((or (not (derived-mode-p 'emacs-lisp-mode))
;; Inside comment or string
(let ((s (syntax-ppss))) (or (nth 3 s) (nth 4 s)))))
(x (if (stringp (car c)) (car c) (string (car c))))
(y (if (stringp (cadr c)) (cadr c) (string (cadr c)))))
(save-excursion
(backward-char (length sym))
(unless (save-excursion
(and (ignore-errors (or (backward-char (length x)) t))
(looking-at-p (regexp-quote x))))
(insert x)))
(unless (looking-at-p (regexp-quote y))
(insert y))))
(defun cape--elisp-symbol-annotation (sym)
"Return kind of SYM."
(setq sym (intern-soft sym))
(cond
((special-form-p sym) " Special")
((macrop sym) " Macro")
((commandp sym) " Command")
((fboundp sym) " Function")
((custom-variable-p sym) " Custom")
((boundp sym) " Variable")
((featurep sym) " Feature")
((facep sym) " Face")
(t " Symbol")))
;;;###autoload
(defun cape-elisp-symbol (&optional interactive)
"Complete Elisp symbol at point.
If INTERACTIVE is nil the function acts like a Capf."
(interactive (list t))
(if interactive
;; No cycling since it breaks the :exit-function.
(let (completion-cycle-threshold)
(cape-interactive #'cape-elisp-symbol))
(pcase-let ((`(,beg . ,end) (cape--bounds 'symbol)))
(when (eq (char-after beg) ?')
(setq beg (1+ beg) end (max beg end)))
`(,beg ,end ,obarray ,@cape--elisp-symbol-properties))))
;;;;; cape-elisp-block
(declare-function org-element-context "org-element")
(declare-function markdown-code-block-lang "ext:markdown-mode")
(defun cape--inside-block-p (&rest langs)
"Return non-nil if inside LANGS code block."
(when-let ((face (get-text-property (point) 'face))
(lang (or (and (if (listp face)
(memq 'org-block face)
(eq 'org-block face))
(plist-get (cadr (org-element-context)) :language))
(and (if (listp face)
(memq 'markdown-code-face face)
(eq 'markdown-code-face face))
(save-excursion
(markdown-code-block-lang))))))
(member lang langs)))
;;;###autoload
(defun cape-elisp-block (&optional interactive)
"Complete Elisp in Org or Markdown code block.
This Capf is particularly useful for literate Emacs configurations.
If INTERACTIVE is nil the function acts like a Capf."
(interactive (list t))
(cond
(interactive
;; No code block check. Always complete Elisp when command was
;; explicitly invoked interactively.
(cape-interactive #'elisp-completion-at-point))
((cape--inside-block-p "elisp" "emacs-lisp")
(elisp-completion-at-point))))
;;;;; cape-dabbrev
(defvar cape--dabbrev-properties
(list :annotation-function (lambda (_) " Dabbrev")
:company-kind (lambda (_) 'text)
:exclusive 'no
:category 'cape-dabbrev)
"Completion extra properties for `cape-dabbrev'.")
(defvar dabbrev-case-replace)
(defvar dabbrev-case-fold-search)
(defvar dabbrev-abbrev-char-regexp)
(defvar dabbrev-abbrev-skip-leading-regexp)
(declare-function dabbrev--find-all-expansions "dabbrev")
(declare-function dabbrev--reset-global-variables "dabbrev")
(defun cape--dabbrev-list (input)
"Find all Dabbrev expansions for INPUT."
(cape--silent
(let* ((chk cape-dabbrev-check-other-buffers)
(funp (and (not (memq chk '(nil t some))) (functionp chk))))
(dlet ((dabbrev-check-other-buffers (and chk (not funp)))
(dabbrev-check-all-buffers (eq chk t))
(dabbrev-search-these-buffers-only (and funp (funcall chk))))
(dabbrev--reset-global-variables)
(cons
(apply-partially #'string-prefix-p input)
(cl-loop with min-len = (+ cape-dabbrev-min-length (length input))
with ic = (cape--case-fold-p dabbrev-case-fold-search)
for w in (dabbrev--find-all-expansions input ic)
if (>= (length w) min-len) collect
(cape--case-replace (and ic dabbrev-case-replace) input w)))))))
(defun cape--dabbrev-bounds ()
"Return bounds of abbreviation."
(unless (boundp 'dabbrev-abbrev-char-regexp)
(require 'dabbrev))
(let ((re (or dabbrev-abbrev-char-regexp "\\sw\\|\\s_"))
(limit (minibuffer-prompt-end)))
(when (or (looking-at re)
(and (> (point) limit)
(save-excursion (forward-char -1) (looking-at re))))
(cons (save-excursion
(while (and (> (point) limit)
(save-excursion (forward-char -1) (looking-at re)))
(forward-char -1))
(when dabbrev-abbrev-skip-leading-regexp
(while (looking-at dabbrev-abbrev-skip-leading-regexp)
(forward-char 1)))
(point))
(save-excursion
(while (looking-at re)
(forward-char 1))
(point))))))
;;;###autoload
(defun cape-dabbrev (&optional interactive)
"Complete with Dabbrev at point.
If INTERACTIVE is nil the function acts like a Capf. In case you
observe a performance issue with auto-completion and `cape-dabbrev'
it is strongly recommended to disable scanning in other buffers.
See the user options `cape-dabbrev-min-length' and
`cape-dabbrev-check-other-buffers'."
(interactive (list t))
(if interactive
(cape-interactive '((cape-dabbrev-min-length 0)) #'cape-dabbrev)
(when-let ((bounds (cape--dabbrev-bounds)))
`(,(car bounds) ,(cdr bounds)
,(completion-table-case-fold
(cape--dynamic-table (car bounds) (cdr bounds) #'cape--dabbrev-list)
(not (cape--case-fold-p dabbrev-case-fold-search)))
,@cape--dabbrev-properties))))
;;;;; cape-dict
(defvar cape--dict-properties
(list :annotation-function (lambda (_) " Dict")
:company-kind (lambda (_) 'text)
:display-sort-function #'identity
:cycle-sort-function #'identity
:exclusive 'no
:category 'cape-dict)
"Completion extra properties for `cape-dict'.")
(defun cape--dict-list (input)
"Return all words from `cape-dict-file' matching INPUT."
(let* ((inhibit-message t)
(message-log-max nil)
(default-directory
(if (and (not (file-remote-p default-directory))
(file-directory-p default-directory))
default-directory
user-emacs-directory))
(files (mapcar #'expand-file-name
(ensure-list
(if (functionp cape-dict-file)
(funcall cape-dict-file)
cape-dict-file))))
(words
(apply #'process-lines-ignore-status
"grep"
(concat "-Fh"
(and (cape--case-fold-p cape-dict-case-fold) "i")
(and cape-dict-limit (format "m%d" cape-dict-limit)))
input files)))
(cons
(apply-partially
(if (and cape-dict-limit (length= words cape-dict-limit))
#'equal #'string-search)
input)
(cape--case-replace-list cape-dict-case-replace input words))))
;;;###autoload
(defun cape-dict (&optional interactive)
"Complete word from dictionary at point.
This completion function works best if the dictionary is sorted
by frequency. See the custom option `cape-dict-file'. If
INTERACTIVE is nil the function acts like a Capf."
(interactive (list t))
(if interactive
(cape-interactive #'cape-dict)
(pcase-let ((`(,beg . ,end) (cape--bounds 'word)))
`( ,beg ,end
,(completion-table-case-fold
(cape--dynamic-table beg end #'cape--dict-list)
(not (cape--case-fold-p cape-dict-case-fold)))
,@cape--dict-properties))))
;;;;; cape-abbrev
(defun cape--abbrev-list ()
"Abbreviation list."
(delete "" (cl-loop for x in (abbrev--suggest-get-active-tables-including-parents)
nconc (all-completions "" x))))
(defun cape--abbrev-annotation (abbrev)
"Annotate ABBREV with expansion."
(concat " "
(truncate-string-to-width
(format
"%s"
(symbol-value
(cl-loop for x in (abbrev--suggest-get-active-tables-including-parents)
thereis (abbrev--symbol abbrev x))))
30 0 nil t)))
(defun cape--abbrev-exit (_str status)
"Expand expansion if STATUS is not exact."
(unless (eq status 'exact)
(expand-abbrev)))
(defvar cape--abbrev-properties
(list :annotation-function #'cape--abbrev-annotation
:exit-function #'cape--abbrev-exit
:company-kind (lambda (_) 'snippet)
:exclusive 'no
:category 'cape-abbrev)
"Completion extra properties for `cape-abbrev'.")
;;;###autoload
(defun cape-abbrev (&optional interactive)
"Complete abbreviation at point.
If INTERACTIVE is nil the function acts like a Capf."
(interactive (list t))
(if interactive
;; No cycling since it breaks the :exit-function.
(let (completion-cycle-threshold)
(cape-interactive #'cape-abbrev))
(when-let (abbrevs (cape--abbrev-list))
(let ((bounds (cape--bounds 'symbol)))
`(,(car bounds) ,(cdr bounds) ,abbrevs ,@cape--abbrev-properties)))))
;;;;; cape-line
(defvar cape--line-properties
(list :display-sort-function #'identity
:cycle-sort-function #'identity
:exclusive 'no
:category 'cape-line)
"Completion extra properties for `cape-line'.")
(defun cape--buffers-major-mode ()
"Return buffers with same major mode as current buffer."
(cl-loop for buf in (buffer-list)
if (eq major-mode (buffer-local-value 'major-mode buf))
collect buf))
(defun cape--line-list ()
"Return all lines from buffer."
(let ((ht (make-hash-table :test #'equal))
(curr-buf (current-buffer))
(buffers (funcall cape-line-buffer-function))
lines)
(dolist (buf (ensure-list buffers))
(with-current-buffer buf
(let ((beg (point-min))
(max (point-max))
(pt (if (eq curr-buf buf) (point) -1))
end)
(save-excursion
(while (< beg max)
(goto-char beg)
(setq end (pos-eol))
(unless (<= beg pt end)
(let ((line (buffer-substring-no-properties beg end)))
(unless (or (string-blank-p line) (gethash line ht))
(puthash line t ht)
(push line lines))))
(setq beg (1+ end)))))))
(nreverse lines)))
;;;###autoload
(defun cape-line (&optional interactive)
"Complete current line from other lines.
The buffers returned by `cape-line-buffer-function' are scanned for lines.
If INTERACTIVE is nil the function acts like a Capf."
(interactive (list t))
(if interactive
(cape-interactive #'cape-line)
`(,(pos-bol) ,(point) ,(cape--line-list) ,@cape--line-properties)))
;;;; Capf combinators
(defun cape--company-call (&rest app)
"Apply APP and handle future return values."
;; Backends are non-interruptible. Disable interrupts!
(let ((toi throw-on-input)
(throw-on-input nil))
(pcase (apply app)
;; Handle async future return values.
(`(:async . ,fetch)
(let ((res 'cape--waiting))
(if toi
(unwind-protect
(progn
(funcall fetch
(lambda (arg)
(when (eq res 'cape--waiting)
(push 'cape--done unread-command-events)
(setq res arg))))
(when (eq res 'cape--waiting)
(let ((ev (let ((input-method-function nil)
(echo-keystrokes 0))
(read-event nil t))))
(unless (eq ev 'cape--done)
(push (cons t ev) unread-command-events)
(setq res 'cape--cancelled)
(throw toi t)))))
(setq unread-command-events
(delq 'cape--done unread-command-events)))
(funcall fetch (lambda (arg) (setq res arg)))
;; Force synchronization, not interruptible! We use polling
;; here and ignore pending input since we don't use
;; `sit-for'. This is the same method used by Company itself.
(while (eq res 'cape--waiting)
(sleep-for 0.01)))
res))
;; Plain old synchronous return value.
(res res))))
(defvar-local cape--company-init nil)
;;;###autoload
(defun cape-company-to-capf (backend &optional valid)
"Convert Company BACKEND function to Capf.
VALID is a function taking the old and new input string. It should
return nil if the cached candidates became invalid. The default value
for VALID is `string-prefix-p' such that the candidates are only fetched
again if the input prefix changed."
(lambda ()
(when (and (symbolp backend) (not (fboundp backend)))
(ignore-errors (require backend nil t)))
(when (bound-and-true-p company-mode)
(error "`cape-company-to-capf' should not be used with `company-mode', use the Company backend directly instead"))
(when (and (symbolp backend) (not (alist-get backend cape--company-init)))
(funcall backend 'init)
(put backend 'company-init t)
(setf (alist-get backend cape--company-init) t))
(when-let ((prefix (cape--company-call backend 'prefix))
(initial-input (if (stringp prefix) prefix (car-safe prefix))))
(let* ((end (point)) (beg (- end (length initial-input)))
(valid (if (cape--company-call backend 'no-cache initial-input)
#'equal (or valid #'string-prefix-p)))
(sort-fun (and (cape--company-call backend 'sorted) #'identity))
restore-props)
(list beg end
(funcall
(if (cape--company-call backend 'ignore-case)
#'completion-table-case-fold
#'identity)
(cape--dynamic-table
beg end
(lambda (input)
(let ((cands (cape--company-call backend 'candidates input)))
;; The candidate string including text properties should be
;; restored in the :exit-function, unless the UI guarantees
;; this itself, like Corfu.
(unless (bound-and-true-p corfu-mode)
(setq restore-props cands))
(cons (apply-partially valid input) cands)))))
:category backend
:exclusive 'no
:company-prefix-length (cdr-safe prefix)
:company-doc-buffer (lambda (x) (cape--company-call backend 'doc-buffer x))
:company-location (lambda (x) (cape--company-call backend 'location x))
:company-docsig (lambda (x) (cape--company-call backend 'meta x))
:company-deprecated (lambda (x) (cape--company-call backend 'deprecated x))
:company-kind (lambda (x) (cape--company-call backend 'kind x))
:display-sort-function sort-fun
:cycle-sort-function sort-fun
:annotation-function (lambda (x)
(when-let (ann (cape--company-call backend 'annotation x))
(concat " " (string-trim ann))))
:exit-function (lambda (x _status)
;; Restore the candidate string including
;; properties if restore-props is non-nil. See
;; the comment above.
(setq x (or (car (member x restore-props)) x))
(cape--company-call backend 'post-completion x)))))))
;;;###autoload
(defun cape-interactive (&rest capfs)
"Complete interactively with the given CAPFS."
(let* ((ctx (and (consp (car capfs)) (car capfs)))
(capfs (if ctx (cdr capfs) capfs))
(completion-at-point-functions
(if ctx
(mapcar (lambda (f) `(lambda () (let ,ctx (funcall ',f)))) capfs)
capfs)))
(unless (completion-at-point)
(user-error "%s: No completions"
(mapconcat (lambda (fun)
(if (symbolp fun)
(symbol-name fun)
"anonymous-capf"))
capfs ", ")))))
;;;###autoload
(defun cape-capf-interactive (capf)
"Create interactive completion function from CAPF."
(lambda (&optional interactive)
(interactive (list t))
(if interactive (cape-interactive capf) (funcall capf))))
;;;###autoload
(defun cape-wrap-super (&rest capfs)
"Call CAPFS and return merged completion result.
The CAPFS list can contain the keyword `:with' to mark the Capfs
afterwards as auxiliary One of the non-auxiliary Capfs before
`:with' must return non-nil for the super Capf to set in and
return a non-nil result. Such behavior is useful when listing
multiple super Capfs in the `completion-at-point-functions':
(setq completion-at-point-functions
(list (cape-capf-super \\='eglot-completion-at-point
:with \\='tempel-complete)
(cape-capf-super \\='cape-dabbrev
:with \\='tempel-complete)))"
(when-let ((results (cl-loop for capf in capfs until (eq capf :with)
for res = (funcall capf)
if res collect (cons t res))))
(pcase-let* ((results (nconc results
(cl-loop for capf in (cdr (memq :with capfs))
for res = (funcall capf)
if res collect (cons nil res))))
(`((,_main ,beg ,end . ,_)) results)
(cand-ht nil)
(tables nil)
(exclusive nil)
(prefix-len nil)
(cand-functions
'( :company-docsig :company-location :company-kind
:company-doc-buffer :company-deprecated
:annotation-function :exit-function)))
(cl-loop for (main beg2 end2 table . plist) in results do
;; Note: `cape-capf-super' currently cannot merge Capfs which
;; trigger at different beginning positions. In order to support
;; this, take the smallest BEG value and then normalize all
;; candidates by prefixing them such that they all start at the
;; smallest BEG position.
(when (= beg beg2)
(push (list main (plist-get plist :predicate) table
;; Plist attached to the candidates
(mapcan (lambda (f)
(when-let ((v (plist-get plist f)))
(list f v)))
cand-functions))
tables)
;; The resulting merged Capf is exclusive if one of the main
;; Capfs is exclusive.
(when (and main (not (eq (plist-get plist :exclusive) 'no)))
(setq exclusive t))
(setq end (max end end2))
(let ((plen (plist-get plist :company-prefix-length)))
(cond
((eq plen t)
(setq prefix-len t))
((and (not prefix-len) (integerp plen))
(setq prefix-len plen))
((and (integerp prefix-len) (integerp plen))
(setq prefix-len (max prefix-len plen)))))))
(setq tables (nreverse tables))
`( ,beg ,end
,(lambda (str pred action)
(pcase action
((or `(boundaries . ,_) 'metadata) nil)
('t ;; all-completions
(let ((ht (make-hash-table :test #'equal))
(candidates nil))
(cl-loop for (main table-pred table cand-plist) in tables do
(let* ((pr (if (and table-pred pred)
(lambda (x) (and (funcall table-pred x) (funcall pred x)))
(or table-pred pred)))
(md (completion-metadata "" table pr))
(sort (or (completion-metadata-get md 'display-sort-function)
#'identity))
;; Always compute candidates of the main Capf
;; tables, which come first in the tables
;; list. For the :with Capfs only compute
;; candidates if we've already determined that
;; main candidates are available.
(cands (when (or main (or exclusive cand-ht candidates))
(funcall sort (all-completions str table pr)))))
;; Handle duplicates with a hash table.
(cl-loop
for cand in-ref cands
for dup = (gethash cand ht t) do
(cond
((eq dup t)
;; Candidate does not yet exist.
(puthash cand cand-plist ht))
((not (equal dup cand-plist))
;; Duplicate candidate. Candidate plist is
;; different, therefore disambiguate the
;; candidates.
(setf cand (propertize cand 'cape-capf-super
(cons cand cand-plist))))))
(when cands (push cands candidates))))
(when (or cand-ht candidates)
(setq candidates (apply #'nconc (nreverse candidates))
cand-ht ht)
candidates)))
(_ ;; try-completion and test-completion
(cl-loop for (_main table-pred table _cand-plist) in tables thereis
(complete-with-action
action table str
(if (and table-pred pred)
(lambda (x) (and (funcall table-pred x) (funcall pred x)))
(or table-pred pred)))))))
:company-prefix-length ,prefix-len
:category cape-super
:display-sort-function identity
:cycle-sort-function identity
,@(and (not exclusive) '(:exclusive no))
,@(mapcan
(lambda (prop)
(list prop
(lambda (cand &rest args)
(if-let ((ref (get-text-property 0 'cape-capf-super cand)))
(when-let ((fun (plist-get (cdr ref) prop)))
(apply fun (car ref) args))
(when-let ((plist (and cand-ht (gethash cand cand-ht)))
(fun (plist-get plist prop)))
(apply fun cand args))))))
cand-functions)))))