Skip to content

Commit ada1928

Browse files
greghendershottgreghendershott
committed
racket-xp-mode: Annotate import bindings with modules
After recently using an affixation-function in the new racket-package-mode, I revived an old branch to annotate imports with their modules. The annotations can be visible in both completion-at-point and read-from-minibuffer completion scenarios. Also add a racket-module completion category. Also review and improve or simplify some adjacent code.
1 parent 6df7559 commit ada1928

File tree

7 files changed

+337
-202
lines changed

7 files changed

+337
-202
lines changed

‎racket-complete.el

Lines changed: 35 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -18,18 +18,18 @@
1818
(end (progn (forward-sexp 1) (point))))
1919
(when (<= (+ beg 2) end) ;prefix at least 2 chars
2020
(funcall proc beg end))))
21-
(error nil)))
22-
(let ((beg (save-excursion (skip-syntax-backward "^-()>") (point))))
23-
(unless (or (eq beg (point-max))
24-
(member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
25-
(condition-case _
26-
(save-excursion
27-
(goto-char beg)
28-
(forward-sexp 1)
29-
(let ((end (point)))
30-
(when (<= (+ beg 2) end) ;prefix at least 2 chars
31-
(funcall proc beg end))))
32-
(error nil)))))
21+
(error nil))
22+
(let ((beg (save-excursion (skip-syntax-backward "^-()>") (point))))
23+
(unless (or (eq beg (point-max))
24+
(member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
25+
(condition-case _
26+
(save-excursion
27+
(goto-char beg)
28+
(forward-sexp 1)
29+
(let ((end (point)))
30+
(when (<= (+ beg 2) end) ;prefix at least 2 chars
31+
(funcall proc beg end))))
32+
(error nil))))))
3333

3434
(defun racket--in-require-form-p ()
3535
(unless forward-sexp-function ;not necessarily sexp lang
@@ -56,21 +56,36 @@
5656
(add-to-list 'completion-category-defaults
5757
`(,racket--identifier-category (styles basic)))
5858

59+
(defconst racket--module-category 'racket-module
60+
"Value for category metadata of module completion tables.")
61+
62+
;; Suggest default; can customize via `completion-category-overrides'.
63+
(add-to-list 'completion-category-defaults
64+
`(,racket--module-category (styles basic)))
65+
5966
(defun racket--completion-table (completions &optional metadata)
60-
"Like `completion-table-dynamic' but also metadata.
67+
"Like `completion-table-dynamic' but also supplies metadata.
6168
6269
METADATA defaults to `((category . ,`racket--identifier-category')).
6370
64-
Category metadata needs to be returned by the completion table
65-
function itself, unlike metadata supplied as properties in the
66-
`completion-at-point-functions' list.
71+
Although sometimes completion metadata is specified as properties
72+
in a `completion-at-point-functions' item, sometimes that is
73+
insufficient or irrelevant -- as with category metadata, or, when
74+
CAPF isn't involved and instead the completion table is given
75+
directly to `completing-read'.
6776
6877
Supplying category metadata allows the user to configure a
69-
completion matching style for that category."
78+
completion matching style for that category. It also prevents
79+
third party packages like marginalia from misclassifying and
80+
displaying inappropriate annotations."
7081
(lambda (prefix predicate action)
71-
(if (eq action 'metadata)
72-
(cons 'metadata (or metadata `((category . ,racket--identifier-category))))
73-
(complete-with-action action completions prefix predicate))))
82+
(pcase action
83+
('metadata
84+
(cons 'metadata
85+
(or metadata
86+
`((category . ,racket--identifier-category)))))
87+
(_
88+
(complete-with-action action completions prefix predicate)))))
7489

7590
(provide 'racket-complete)
7691

‎racket-doc.el

Lines changed: 15 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -22,19 +22,21 @@
2222

2323
(defun racket--doc (prefix how completions)
2424
"A helper for `racket-xp-documentation' and `racket-repl-documentation'."
25-
(let ((search-p (equal prefix '(16))))
26-
(pcase (racket--symbol-at-point-or-prompt prefix
27-
"Documentation for: "
28-
(unless search-p completions)
29-
search-p)
30-
((and (pred stringp) str)
31-
(if search-p
32-
(racket--search-doc str)
33-
(racket--doc-assert-local-back-end)
34-
(racket--doc-command (when (eq how 'namespace)
35-
(racket--repl-session-id))
36-
how
37-
str))))))
25+
(racket--doc-assert-local-back-end)
26+
(cond
27+
((equal prefix '(16))
28+
(when-let (str (read-from-minibuffer
29+
"Search documentation for text: "))
30+
(racket--search-doc str)))
31+
(t
32+
(when-let (str (racket--symbol-at-point-or-prompt
33+
prefix
34+
"Documentation for: "
35+
completions))
36+
(racket--doc-command (when (eq how 'namespace)
37+
(racket--repl-session-id))
38+
how
39+
str)))))
3840

3941
(defun racket--doc-command (repl-session-id how str)
4042
"A helper for `racket--doc', `racket-xp-describe', and `racket-repl-describe'.

‎racket-package.el

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -173,7 +173,7 @@ Allows users to customize via `completion-category-overrides'.")
173173
stat
174174
(make-string (- max-stat (length stat)) 32)
175175
desc)
176-
'face 'font-lock-comment-face)))))
176+
'face 'completions-annotations)))))
177177
vs)))
178178
(val (completing-read "Describe Racket package: "
179179
(racket--completion-table

‎racket-xp-complete.el

Lines changed: 80 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -8,17 +8,81 @@
88

99
;; SPDX-License-Identifier: GPL-3.0-or-later
1010

11+
(require 'seq)
1112
(require 'racket-complete)
1213
(require 'racket-describe)
1314
(require 'racket-company-doc)
1415

15-
(defvar-local racket--xp-binding-completions nil
16-
"Completion candidates that are bindings.
17-
Set by `racket-xp-mode'. Used by `racket-xp-complete-at-point'.")
16+
(defvar-local racket--xp-completion-table-all nil
17+
"A completion table of all bindings; for use by a CAPF.
18+
19+
Includes both imports and lexical bindings. Better for use by
20+
`completion-at-point' in an edit buffer, because in general more
21+
completion candidates offer more opportunities to minimize
22+
typing.
23+
24+
The table includes category and affixation-function metadata; the
25+
latter shows the module from which an identifier was imported,
26+
when not a lexical binding.")
27+
28+
(defvar-local racket--xp-completion-table-imports nil
29+
"A completion table of import bindings; for use in minibuffer.
30+
31+
Includes only imports, not lexical bindings. Definitely better
32+
for use by commands that look up documentation. Sometimes better
33+
for use by `completing-read' in the minibuffer, because that
34+
returns strings stripped of all text properties -- unless a
35+
command is able to find a suitable matching string in the buffer
36+
and use its text properties.
37+
38+
The table includes category and affixation-funciton metadata.")
39+
40+
(defun racket--set-xp-binding-completions (mods+syms)
41+
;; The back end gives us data optimized for space when serializing:
42+
;;
43+
;; ((modA symA0 symA1 ...)
44+
;; (modB symB0 symB1 ...) ...)
45+
;;
46+
;; Reshape that to a list of strings, each propertized with is mod,
47+
;; for use as completion table.
48+
(let ((all nil)
49+
(imports nil)
50+
(metadata `((category . ,racket--identifier-category)
51+
(affixation-function . ,#'racket--xp-binding-completion-affixator))))
52+
(dolist (mod+syms mods+syms)
53+
(pcase-let ((`(,mod . ,syms) mod+syms))
54+
(dolist (sym syms)
55+
(push (propertize sym 'racket-module mod) all)
56+
(when mod
57+
(push (propertize sym 'racket-module mod) imports)))))
58+
(setq racket--xp-completion-table-all
59+
(racket--completion-table all metadata))
60+
(setq racket--xp-completion-table-imports
61+
(racket--completion-table imports metadata))))
62+
63+
(defun racket--xp-binding-completion-affixator (strs)
64+
"Value for :affixation-function."
65+
(let ((max-len (seq-reduce (lambda (max-len str)
66+
(max max-len (1+ (length str))))
67+
strs
68+
15)))
69+
(seq-map (lambda (str)
70+
(let* ((leading-space (make-string (- max-len (length str)) 32))
71+
(mod (get-text-property 0 'racket-module str))
72+
(suffix (or mod ""))
73+
(suffix (propertize suffix 'face 'completions-annotations))
74+
(suffix (concat leading-space suffix)))
75+
(list str "" suffix)))
76+
strs)))
1877

1978
(defvar-local racket--xp-module-completions nil
20-
"Completion candidates that are available collection module paths.
21-
Set by `racket-xp-mode'. Used by `racket-xp-complete-at-point'.")
79+
"A completion table for available collection module paths.
80+
Do not `setq' directly; instead call `racket--xp-set-module-completions'.")
81+
82+
(defun racket--set-xp-module-completions (completions)
83+
(setq-local racket--xp-module-completions
84+
(racket--completion-table completions
85+
`((category . ,racket--module-category)))))
2286

2387
(defun racket-xp-complete-at-point ()
2488
"A value for the variable `completion-at-point-functions'.
@@ -51,10 +115,11 @@ Set by `racket-xp-mode'. Used by `racket-xp-complete-at-point'.")
51115
(defun racket--xp-capf-bindings (beg end)
52116
(list beg
53117
end
54-
(racket--completion-table racket--xp-binding-completions)
55-
:exclusive 'no
56-
:company-location (racket--xp-make-company-location-proc)
57-
:company-doc-buffer (racket--xp-make-company-doc-buffer-proc)))
118+
racket--xp-completion-table-all
119+
:affixation-function #'racket--xp-binding-completion-affixator
120+
:exclusive 'no
121+
:company-location (racket--xp-make-company-location-proc)
122+
:company-doc-buffer (racket--xp-make-company-doc-buffer-proc)))
58123

59124
(defun racket--xp-capf-require-transformers (beg end)
60125
"Note: Currently this returns too many candidates -- all
@@ -70,23 +135,15 @@ that are require transformers."
70135
(defun racket--xp-capf-absolute-module-paths (beg end)
71136
(list beg
72137
end
73-
(racket--completion-table racket--xp-module-completions)
138+
racket--xp-module-completions
74139
:exclusive 'no))
75140

76141
(defun racket--xp-capf-relative-module-paths ()
77-
(pcase (thing-at-point 'filename t)
78-
((and (pred stringp) str)
79-
(pcase-let ((`(,beg . ,end) (bounds-of-thing-at-point 'filename)))
80-
(pcase (completion-file-name-table str #'file-exists-p t)
81-
((and (pred listp) table)
82-
(let* ((dir (file-name-directory str))
83-
(table (mapcar (lambda (v) (concat dir v)) ;#466
84-
table)))
85-
(list beg
86-
end
87-
(racket--completion-table table
88-
'((category . file)))
89-
:exclusive 'no))))))))
142+
(when-let (bounds (bounds-of-thing-at-point 'filename))
143+
(list (car bounds)
144+
(cdr bounds)
145+
#'completion-file-name-table
146+
:exclusive 'no)))
90147

91148
(defun racket--xp-make-company-location-proc ()
92149
(when (racket--cmd-open-p)

0 commit comments

Comments
 (0)