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
|
;;; racket-complete.el -*- lexical-binding: t -*-
;; Copyright (c) 2013-2024 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-common)
(defun racket--call-with-completion-prefix-positions (proc)
(cl-flet ((maybe-call (beg end)
(when (and (<= (+ beg 2) end) ;prefix at least 2 chars
(eq (line-number-at-pos beg)
(line-number-at-pos end)))
(funcall proc beg end))))
(if forward-sexp-function ;not necessarily sexp lang
(condition-case _
(save-excursion
(let ((beg (progn (forward-sexp -1) (point)))
(end (progn (forward-sexp 1) (point))))
(maybe-call beg end)))
(error nil))
(let ((beg (save-excursion (skip-syntax-backward "^-()>") (point))))
(unless (or (eq beg (point-max))
(member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
(condition-case _
(save-excursion
(goto-char beg)
(forward-sexp 1)
(maybe-call beg (point)))
(error nil)))))))
(defun racket--in-require-form-p ()
(unless forward-sexp-function ;not necessarily sexp lang
(save-excursion
(save-match-data
(racket--escape-string-or-comment)
(let ((done nil)
(result nil))
(condition-case _
(while (not done)
(backward-up-list)
(when (looking-at-p (rx ?\( (or "require" "#%require")))
(setq done t)
(setq result t)))
(scan-error nil))
result)))))
;;; Completion tables with "category" metadata
(defconst racket--identifier-category 'racket-identifier
"Value for category metadata of identifier completion tables.")
;; Suggest default; can customize via `completion-category-overrides'.
(add-to-list 'completion-category-defaults
`(,racket--identifier-category (styles basic)))
(defconst racket--module-category 'racket-module
"Value for category metadata of module completion tables.")
;; Suggest default; can customize via `completion-category-overrides'.
(add-to-list 'completion-category-defaults
`(,racket--module-category (styles basic)))
(defun racket--completion-table (completions &optional metadata)
"Like `completion-table-dynamic' but also supplies metadata.
METADATA defaults to `((category . ,`racket--identifier-category')).
Although sometimes completion metadata is specified as properties
in a `completion-at-point-functions' item, sometimes that is
insufficient or irrelevant -- as with category metadata, or, when
CAPF isn't involved and instead the completion table is given
directly to `completing-read'.
Supplying category metadata allows the user to configure a
completion matching style for that category. It also prevents
third party packages like marginalia from misclassifying and
displaying inappropriate annotations."
(lambda (prefix predicate action)
(pcase action
('metadata
(cons 'metadata
(or metadata
`((category . ,racket--identifier-category)))))
(_
(complete-with-action action completions prefix predicate)))))
(defun racket--make-affix (specs &optional prop)
"Make an affixation-function to show completion annotations.
For more information about affixation-function completion
metadata, see Info node `(elisp)Programmed Completion'.
PROP is the symbol name of a text property that must be attached
to each of the completion candidate strings. The value of the
property is a list of strings -- each string is a suffix column
value to show as an annotation. The list length must be the same
for all candidate strings. The property name defaults to
\\='racket-affix.
SPECS is a vector of specs for each column -- one for the
completion candidate string, plus the length of the list of
suffix columns. Each spec may be an integer, which is a minimum
width, or [WIDTH FACE]. Note: The width is N/A for the last
suffix column. The face is N/A for the first column, which shows
the candidate string. For suffix columns, the face defaults to
completions-anntoations. An explicit nil value in the spec means
not to add a face, because the string is already propertized with
one.
The affixation-function arranges for each suffix column to be
aligned, considering the minimum width and the maximum width of
the previous column.
When a candidate string ends with text made invisible by a
\\='display \"\" property -- as is done by
`racket--doc-index-make-alist' -- that text is ignored for
purposes of calculating widths."
;; Note: Below we use `cl-loop' because `seq-do-indexed' and
;; `seq-map-indexed' are unavailable in Emacs 25.
(let ((min-widths (cl-loop
for spec across specs
collect (pcase spec
(`[,width ,_face] width)
((and (pred numberp) width) width)
(_ 0))))
(suffix-faces (cl-loop for spec across (seq-drop specs 1)
collect (pcase spec
(`[,_width ,face] face)
(_ 'completions-annotations))))
(prop (or prop 'racket-affix)))
(lambda (strs)
(let* ((max-widths (apply #'vector min-widths))
(rows
(cl-loop
for str in strs
collect
(let ((visible-str
(substring str
0
(text-property-any 0 (length str)
'display ""
str)))
(suffixes (get-text-property 0 prop str)))
;; Mutate `max-widths'.
(cl-loop
for col in (cons visible-str suffixes)
for ix from 0
do (aset max-widths ix
(max (aref max-widths ix)
(1+ (length col)))))
(cons str suffixes))))
(suffix-offsets
(let ((offset 0))
(cl-loop
for max-width across max-widths
collect
(setq offset (+ offset max-width))))))
(cl-loop
for row in rows
collect
(pcase-let*
((`(,str . ,suffixes) row)
(suffixes-str
(cl-loop
for suffix in suffixes
for offset in suffix-offsets
for face in suffix-faces
concat
(concat
(propertize " "
'display
`(space :align-to ,offset))
(if face
(propertize (or suffix "")
'face face)
(or suffix ""))))))
(list str "" suffixes-str)))))))
(provide 'racket-complete)
;; racket-complete.el ends here
|
