[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] elpa/racket-mode ada192863b 2/2: racket-xp-mode: Annotate impor
|
From: |
ELPA Syncer |
|
Subject: |
[nongnu] elpa/racket-mode ada192863b 2/2: racket-xp-mode: Annotate import bindings with modules |
|
Date: |
Mon, 29 Jul 2024 13:00:37 -0400 (EDT) |
branch: elpa/racket-mode
commit ada192863b0eb162c31015345f0158828e9dba22
Author: Greg Hendershott <git@greghendershott.com>
Commit: Greg Hendershott <git@greghendershott.com>
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.
---
racket-complete.el | 55 +++++---
racket-doc.el | 28 +++--
racket-package.el | 2 +-
racket-xp-complete.el | 103 +++++++++++----
racket-xp.el | 264 +++++++++++++++++++++++----------------
racket/commands/check-syntax.rkt | 15 +--
racket/imports.rkt | 72 ++++++-----
7 files changed, 337 insertions(+), 202 deletions(-)
diff --git a/racket-complete.el b/racket-complete.el
index 797b3b628d..7fda66fb91 100644
--- a/racket-complete.el
+++ b/racket-complete.el
@@ -18,18 +18,18 @@
(end (progn (forward-sexp 1) (point))))
(when (<= (+ beg 2) end) ;prefix at least 2 chars
(funcall proc 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)
- (let ((end (point)))
- (when (<= (+ beg 2) end) ;prefix at least 2 chars
- (funcall proc beg end))))
- (error nil)))))
+ (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)
+ (let ((end (point)))
+ (when (<= (+ beg 2) end) ;prefix at least 2 chars
+ (funcall proc beg end))))
+ (error nil))))))
(defun racket--in-require-form-p ()
(unless forward-sexp-function ;not necessarily sexp lang
@@ -56,21 +56,36 @@
(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 metadata.
+ "Like `completion-table-dynamic' but also supplies metadata.
METADATA defaults to `((category . ,`racket--identifier-category')).
-Category metadata needs to be returned by the completion table
-function itself, unlike metadata supplied as properties in the
-`completion-at-point-functions' list.
+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."
+completion matching style for that category. It also prevents
+third party packages like marginalia from misclassifying and
+displaying inappropriate annotations."
(lambda (prefix predicate action)
- (if (eq action 'metadata)
- (cons 'metadata (or metadata `((category .
,racket--identifier-category))))
- (complete-with-action action completions prefix predicate))))
+ (pcase action
+ ('metadata
+ (cons 'metadata
+ (or metadata
+ `((category . ,racket--identifier-category)))))
+ (_
+ (complete-with-action action completions prefix predicate)))))
(provide 'racket-complete)
diff --git a/racket-doc.el b/racket-doc.el
index a334f8106a..574be59136 100644
--- a/racket-doc.el
+++ b/racket-doc.el
@@ -22,19 +22,21 @@
(defun racket--doc (prefix how completions)
"A helper for `racket-xp-documentation' and `racket-repl-documentation'."
- (let ((search-p (equal prefix '(16))))
- (pcase (racket--symbol-at-point-or-prompt prefix
- "Documentation for: "
- (unless search-p completions)
- search-p)
- ((and (pred stringp) str)
- (if search-p
- (racket--search-doc str)
- (racket--doc-assert-local-back-end)
- (racket--doc-command (when (eq how 'namespace)
- (racket--repl-session-id))
- how
- str))))))
+ (racket--doc-assert-local-back-end)
+ (cond
+ ((equal prefix '(16))
+ (when-let (str (read-from-minibuffer
+ "Search documentation for text: "))
+ (racket--search-doc str)))
+ (t
+ (when-let (str (racket--symbol-at-point-or-prompt
+ prefix
+ "Documentation for: "
+ completions))
+ (racket--doc-command (when (eq how 'namespace)
+ (racket--repl-session-id))
+ how
+ str)))))
(defun racket--doc-command (repl-session-id how str)
"A helper for `racket--doc', `racket-xp-describe', and
`racket-repl-describe'.
diff --git a/racket-package.el b/racket-package.el
index cc6af4cf46..bc8002f813 100644
--- a/racket-package.el
+++ b/racket-package.el
@@ -173,7 +173,7 @@ Allows users to customize via
`completion-category-overrides'.")
stat
(make-string (- max-stat (length stat)) 32)
desc)
- 'face 'font-lock-comment-face)))))
+ 'face 'completions-annotations)))))
vs)))
(val (completing-read "Describe Racket package: "
(racket--completion-table
diff --git a/racket-xp-complete.el b/racket-xp-complete.el
index d57a9a0fe9..02f76aa3c8 100644
--- a/racket-xp-complete.el
+++ b/racket-xp-complete.el
@@ -8,17 +8,81 @@
;; SPDX-License-Identifier: GPL-3.0-or-later
+(require 'seq)
(require 'racket-complete)
(require 'racket-describe)
(require 'racket-company-doc)
-(defvar-local racket--xp-binding-completions nil
- "Completion candidates that are bindings.
-Set by `racket-xp-mode'. Used by `racket-xp-complete-at-point'.")
+(defvar-local racket--xp-completion-table-all nil
+ "A completion table of all bindings; for use by a CAPF.
+
+Includes both imports and lexical bindings. Better for use by
+`completion-at-point' in an edit buffer, because in general more
+completion candidates offer more opportunities to minimize
+typing.
+
+The table includes category and affixation-function metadata; the
+latter shows the module from which an identifier was imported,
+when not a lexical binding.")
+
+(defvar-local racket--xp-completion-table-imports nil
+ "A completion table of import bindings; for use in minibuffer.
+
+Includes only imports, not lexical bindings. Definitely better
+for use by commands that look up documentation. Sometimes better
+for use by `completing-read' in the minibuffer, because that
+returns strings stripped of all text properties -- unless a
+command is able to find a suitable matching string in the buffer
+and use its text properties.
+
+The table includes category and affixation-funciton metadata.")
+
+(defun racket--set-xp-binding-completions (mods+syms)
+ ;; The back end gives us data optimized for space when serializing:
+ ;;
+ ;; ((modA symA0 symA1 ...)
+ ;; (modB symB0 symB1 ...) ...)
+ ;;
+ ;; Reshape that to a list of strings, each propertized with is mod,
+ ;; for use as completion table.
+ (let ((all nil)
+ (imports nil)
+ (metadata `((category . ,racket--identifier-category)
+ (affixation-function .
,#'racket--xp-binding-completion-affixator))))
+ (dolist (mod+syms mods+syms)
+ (pcase-let ((`(,mod . ,syms) mod+syms))
+ (dolist (sym syms)
+ (push (propertize sym 'racket-module mod) all)
+ (when mod
+ (push (propertize sym 'racket-module mod) imports)))))
+ (setq racket--xp-completion-table-all
+ (racket--completion-table all metadata))
+ (setq racket--xp-completion-table-imports
+ (racket--completion-table imports metadata))))
+
+(defun racket--xp-binding-completion-affixator (strs)
+ "Value for :affixation-function."
+ (let ((max-len (seq-reduce (lambda (max-len str)
+ (max max-len (1+ (length str))))
+ strs
+ 15)))
+ (seq-map (lambda (str)
+ (let* ((leading-space (make-string (- max-len (length str)) 32))
+ (mod (get-text-property 0 'racket-module str))
+ (suffix (or mod ""))
+ (suffix (propertize suffix 'face
'completions-annotations))
+ (suffix (concat leading-space suffix)))
+ (list str "" suffix)))
+ strs)))
(defvar-local racket--xp-module-completions nil
- "Completion candidates that are available collection module paths.
-Set by `racket-xp-mode'. Used by `racket-xp-complete-at-point'.")
+ "A completion table for available collection module paths.
+Do not `setq' directly; instead call `racket--xp-set-module-completions'.")
+
+(defun racket--set-xp-module-completions (completions)
+ (setq-local racket--xp-module-completions
+ (racket--completion-table completions
+ `((category .
,racket--module-category)))))
(defun racket-xp-complete-at-point ()
"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'.")
(defun racket--xp-capf-bindings (beg end)
(list beg
end
- (racket--completion-table racket--xp-binding-completions)
- :exclusive 'no
- :company-location (racket--xp-make-company-location-proc)
- :company-doc-buffer (racket--xp-make-company-doc-buffer-proc)))
+ racket--xp-completion-table-all
+ :affixation-function #'racket--xp-binding-completion-affixator
+ :exclusive 'no
+ :company-location (racket--xp-make-company-location-proc)
+ :company-doc-buffer (racket--xp-make-company-doc-buffer-proc)))
(defun racket--xp-capf-require-transformers (beg end)
"Note: Currently this returns too many candidates -- all
@@ -70,23 +135,15 @@ that are require transformers."
(defun racket--xp-capf-absolute-module-paths (beg end)
(list beg
end
- (racket--completion-table racket--xp-module-completions)
+ racket--xp-module-completions
:exclusive 'no))
(defun racket--xp-capf-relative-module-paths ()
- (pcase (thing-at-point 'filename t)
- ((and (pred stringp) str)
- (pcase-let ((`(,beg . ,end) (bounds-of-thing-at-point 'filename)))
- (pcase (completion-file-name-table str #'file-exists-p t)
- ((and (pred listp) table)
- (let* ((dir (file-name-directory str))
- (table (mapcar (lambda (v) (concat dir v)) ;#466
- table)))
- (list beg
- end
- (racket--completion-table table
- '((category . file)))
- :exclusive 'no))))))))
+ (when-let (bounds (bounds-of-thing-at-point 'filename))
+ (list (car bounds)
+ (cdr bounds)
+ #'completion-file-name-table
+ :exclusive 'no)))
(defun racket--xp-make-company-location-proc ()
(when (racket--cmd-open-p)
diff --git a/racket-xp.el b/racket-xp.el
index a7d439a428..78342d3658 100644
--- a/racket-xp.el
+++ b/racket-xp.el
@@ -278,7 +278,7 @@ commands directly to whatever keys you prefer.
(racket--cmd/async nil
`(module-names)
(lambda (result)
- (setq racket--xp-module-completions result)))
+ (racket--set-xp-module-completions result)))
(add-hook 'xref-backend-functions
#'racket-xp-xref-backend-function
nil t)
@@ -427,7 +427,7 @@ manually."
(when (equal next-error-last-buffer (current-buffer))
(setq next-error-last-buffer nil))
(racket--xp-clear)
- (setq racket--xp-binding-completions completions)
+ (racket--set-xp-binding-completions completions)
(setq racket--xp-imenu-index imenu)
(racket--xp-insert annotations)
(racket--xp-set-status 'ok)
@@ -572,7 +572,7 @@ point."
(remove-text-properties (point-min) (point-max)
(list 'help-echo nil))
(unless only-errors-p
- (setq racket--xp-binding-completions nil)
+ (racket--set-xp-binding-completions nil)
(setq racket--xp-imenu-index nil)
(racket--remove-overlays-in-buffer racket-xp-def-face
racket-xp-use-face
@@ -594,63 +594,6 @@ point."
;; remove only those.
'font-lock-face nil)))))
-;;; xref
-
-(defun racket-xp-describe (&optional prefix)
- "Describe the identifier at point.
-
-The command varies based on how many \\[universal-argument] command prefixes
you supply.
-\\<racket-xp-mode-map>
-
-- \\[racket-xp-describe]
-
- Uses the symbol at point. If no such symbol exists, you are
- prompted enter the identifier, but in this case it only
- considers definitions or imports at the file's module level --
- not local bindings nor definitions in submodules.
-
- - If the identifier has installed Racket documentation, then a
- simplified version of the HTML is presented in the buffer,
- including the \"blue box\", documentation prose, and
- examples.
-
- - Otherwise, if the identifier is a function, then its
- signature is displayed, for example \"\(name arg-1-name
- arg-2-name\)\".
-
-- \\[universal-argument] \\[racket-xp-describe]
-
- Always prompts you to enter a symbol, defaulting to the symbol
- at point if any.
-
-- \\[universal-argument] \\[universal-argument] \\[racket-xp-describe]
-
- This is an alias for `racket-describe-search', which uses
- installed documentation in a `racket-describe-mode' buffer
- instead of an external web browser.
-
-The intent is to give a quick reminder or introduction to
-something, regardless of whether it has installed documentation
--- and to do so within Emacs, without switching to a web browser.
-
-This buffer is also displayed when you use `company-mode' and
-press F1 or C-h in its pop up completion list."
- (interactive "P")
- (if (equal prefix '(16))
- (racket-describe-search)
- (pcase (racket--symbol-at-point-or-prompt prefix "Describe: "
- racket--xp-binding-completions)
- ((and (pred stringp) str)
- ;; When there is a racket-xp-doc property, use its path and
- ;; anchor, because that will be correct even for an identifier
- ;; in a submodule with different imports than the file module.
- ;; Else supply the file path-str, and the "describe" command
- ;; will treat it as a file module identifier.
- (let ((how (pcase (get-text-property (point) 'racket-xp-doc)
- (`(,path ,anchor) `(,path . ,anchor))
- (_ (racket--buffer-file-name)))))
- (racket--do-describe how nil str))))))
-
(defun racket-xp-eldoc-function ()
"A value for the variable `eldoc-documentation-function'.
@@ -835,7 +778,7 @@ command prefixes you supply.
((and `(,path ,anchor) (guard (not prefix)))
(racket-browse-file-url path anchor))
(_
- (racket--doc prefix (buffer-file-name) racket--xp-binding-completions))))
+ (racket--doc prefix (buffer-file-name)
racket--xp-completion-table-imports))))
;;; Navigation
@@ -1044,8 +987,99 @@ around at the first and last errors."
(interactive)
(previous-error))
+;;; describe
+
+(defun racket-xp-describe (&optional prefix)
+ "Describe the identifier at point.
+
+The command varies based on how many \\[universal-argument] command prefixes
you supply.
+\\<racket-xp-mode-map>
+
+- \\[racket-xp-describe]
+
+ Uses the symbol at point. If no such symbol exists, you are
+ prompted enter the identifier, but in this case it only
+ considers definitions or imports at the file's module level --
+ not local bindings nor definitions in submodules.
+
+ - If the identifier has installed Racket documentation, then a
+ simplified version of the HTML is presented in the buffer,
+ including the \"blue box\", documentation prose, and
+ examples.
+
+ - Otherwise, if the identifier is a function, then its
+ signature is displayed, for example \"\(name arg-1-name
+ arg-2-name\)\".
+
+- \\[universal-argument] \\[racket-xp-describe]
+
+ Always prompts you to enter a symbol, defaulting to the symbol
+ at point if any.
+
+- \\[universal-argument] \\[universal-argument] \\[racket-xp-describe]
+
+ This is an alias for `racket-describe-search', which uses
+ installed documentation in a `racket-describe-mode' buffer
+ instead of an external web browser.
+
+The intent is to give a quick reminder or introduction to
+something, regardless of whether it has installed documentation
+-- and to do so within Emacs, without switching to a web browser.
+
+This buffer is also displayed when you use `company-mode' and
+press F1 or C-h in its pop up completion list."
+ (interactive "P")
+ (if (equal prefix '(16))
+ (racket-describe-search)
+ (pcase (racket--symbol-at-point-or-prompt
+ prefix "Describe: "
+ racket--xp-completion-table-all)
+ ((and (pred stringp) str)
+ ;; When user did /not/ supply command prefix to input an
+ ;; arbitrary string, we can look for a racket-xp-doc property
+ ;; at point. If available, use its path and anchor, because
+ ;; that will be correct even for an identifier in a submodule
+ ;; with different imports than the file module. Otherwise
+ ;; supply the file's path, and the "describe" command will
+ ;; treat str as a file module identifier.
+ (let ((how (pcase (and (not prefix)
+ (get-text-property (point) 'racket-xp-doc))
+ (`(,path ,anchor) `(,path . ,anchor))
+ (_ (racket--buffer-file-name)))))
+ (racket--do-describe how nil str))))))
+
;;; xref
+(defconst racket--xp-props-for-xref
+ '(racket-xp-require
+ racket-xp-visit
+ racket-xp-use
+ racket-xp-def))
+
+(defun racket--xp-props-for-xref-at (pos &optional object)
+ (when-let (plist (text-properties-at pos object))
+ (seq-some (lambda (p) (plist-member plist p))
+ racket--xp-props-for-xref)))
+
+(defun racket--xp-find-propertized-string (str)
+ "Find string in buffer matching STR and having one of our properties.
+When found, returns the buffer string and all its properties,
+else returns STR."
+ (save-restriction
+ (widen)
+ (save-excursion
+ (goto-char (point-min))
+ (save-match-data
+ (let ((result nil))
+ (while (and (not result)
+ (< (point) (point-max)))
+ (if (search-forward str nil t)
+ (when (and (equal (thing-at-point 'symbol) str)
+ (racket--xp-props-for-xref-at (match-beginning 0)))
+ (setq result (match-string 0)))
+ (goto-char (point-max))))
+ (or result str))))))
+
(defun racket-xp-xref-backend-function ()
'racket-xp-xref)
@@ -1055,60 +1089,72 @@ around at the first and last errors."
(let* ((end (next-single-property-change (point) prop))
(beg (previous-single-property-change end prop)))
(save-restriction (widen) (buffer-substring beg end)))))
- ;; Consider same props our xref-backend-definitions
- ;; method looks for.
- '(racket-xp-require
- racket-xp-visit
- racket-xp-use
- racket-xp-def))
+ racket--xp-props-for-xref)
(thing-at-point 'symbol)))
(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql
racket-xp-xref)))
- (completion-table-dynamic
- (lambda (prefix)
- (all-completions prefix racket--xp-binding-completions))))
+ racket--xp-completion-table-all)
(cl-defmethod xref-backend-definitions ((_backend (eql racket-xp-xref)) str)
- (or
- ;; Something annotated as add-open-reuqire-menu by drracket/check-syntax
- (when-let (path (get-text-property 0 'racket-xp-require str))
- (list (xref-make str (xref-make-file-location path 1 0))))
- ;; Something annotated for jump-to-definition by drracket/check-syntax
- (pcase (get-text-property 0 'racket-xp-visit str)
- (`(,path ,subs ,ids)
- (pcase (racket--cmd/await nil
- `(def/drr
- ,(racket-file-name-front-to-back
- (racket--buffer-file-name))
- ,(racket-file-name-front-to-back path)
- ,subs
- ,ids))
+ ;; If xref used `completing-read', then STR will have no text
+ ;; properties, which limits what we can do with it. Try to find a
+ ;; matching string in the buffer to use, so we can use one of its
+ ;; `racket--xp-props-for-xref'.
+ (let ((str (if (not (racket--xp-props-for-xref-at 0 str))
+ (racket--xp-find-propertized-string str)
+ str)))
+ (list
+ (or
+ ;; Something annotated as add-open-require-menu by drracket/check-syntax
+ (when-let (path (get-text-property 0 'racket-xp-require str))
+ (list (xref-make str (xref-make-file-location path 1 0))))
+ ;; Something annotated for jump-to-definition by drracket/check-syntax
+ (pcase (get-text-property 0 'racket-xp-visit str)
+ (`(,path ,subs ,ids)
+ (pcase (racket--cmd/await nil
+ `(def/drr
+ ,(racket-file-name-front-to-back
+ (racket--buffer-file-name))
+ ,(racket-file-name-front-to-back path)
+ ,subs
+ ,ids))
+ (`(,path ,line ,col)
+ (xref-make str
+ (xref-make-file-location
+ (racket-file-name-back-to-front path) line col))))))
+ (pcase (get-text-property 0 'racket-xp-use str)
+ (`(,beg ,end)
+ (xref-make (save-restriction (widen) (buffer-substring beg end))
+ (xref-make-buffer-location (current-buffer)
+ (marker-position beg)))))
+ (pcase (get-text-property 0 'racket-xp-def str)
+ (`(local ,id ((,use-beg ,_use-end) . ,_))
+ (when-let (def-beg (car (get-text-property use-beg 'racket-xp-use)))
+ (xref-make id
+ (xref-make-buffer-location (current-buffer)
+ (marker-position def-beg)))))
+ ;; Annotated by dr/cs as imported module; visit the module
+ (`(import ,id . ,_)
+ (xref-backend-definitions 'racket-xref-module id)))
+ ;; Something that, for whatever reason, drracket/check-syntax
+ ;; did not annotate. Use the back end `def` command (although it
+ ;; can only find definitions imported at the file module level,
+ ;; not submodules, since all we give it is a plain string and no
+ ;; position.)
+ (pcase (racket--cmd/await nil `(def ,(racket-file-name-front-to-back
+ (racket--buffer-file-name))
+ ,(substring-no-properties str)))
(`(,path ,line ,col)
- (list (xref-make str
- (xref-make-file-location
- (racket-file-name-back-to-front path) line
col)))))))
- (pcase (get-text-property 0 'racket-xp-use str)
- (`(,beg ,end)
- (list
- (xref-make (save-restriction (widen) (buffer-substring beg end))
- (xref-make-buffer-location (current-buffer)
- (marker-position beg))))))
- ;; Annotated by dr/cs as imported module; visit the module
- (pcase (get-text-property 0 'racket-xp-def str)
- (`(import ,id . ,_)
- (xref-backend-definitions 'racket-xref-module id)))
- ;; Something that, for whatever reason, drracket/check-syntax did
- ;; not annotate.
- (pcase (racket--cmd/await nil `(def ,(racket-file-name-front-to-back
- (racket--buffer-file-name))
- ,(substring-no-properties str)))
- (`(,path ,line ,col)
- (list (xref-make str
- (xref-make-file-location path line col))))
- (`kernel
- (list (xref-make str
- (xref-make-bogus-location
- "Defined in #%%kernel -- source not available")))))))
+ (xref-make str
+ (xref-make-file-location path line col)))
+ (`kernel
+ (xref-make str
+ (xref-make-bogus-location
+ "Defined in #%%kernel -- source not available")))
+ (_
+ (xref-make str
+ (xref-make-bogus-location
+ "Cannot find definition; maybe if identifier is imported
in a submodule but not used"))))))))
(cl-defmethod xref-backend-references ((backend (eql racket-xp-xref)) str)
;; Note: Our ability to find references is limited to those
diff --git a/racket/commands/check-syntax.rkt b/racket/commands/check-syntax.rkt
index 21a5c1aeb3..b4bf912527 100644
--- a/racket/commands/check-syntax.rkt
+++ b/racket/commands/check-syntax.rkt
@@ -102,11 +102,10 @@
(with-time/log 'get-annotations
(send (current-annotations) get-annotations)))
- (define completions-set (send (current-annotations)
get-local-completion-candidates))
- (with-time/log 'imports
- (imports stx completions-set))
- (define completions (sort (set->list completions-set)
- string<=?))
+ (define completions
+ (cons (cons #f (send (current-annotations)
get-local-completion-candidates))
+ (for/list ([(k v) (in-hash (imports stx))])
+ (cons k (set->list v)))))
(define imenu (send (current-annotations) get-imenu-index))
@@ -211,7 +210,8 @@
;; imported that _could_ be used.
(when (or (regexp-match? #px"^\\d+ bound occurrences?$" status)
(equal? status "no bound occurrences"))
- (set-add! local-completion-candidates (substring code-str beg
end)))))
+ (set-add! local-completion-candidates
+ (substring code-str beg end)))))
;; These are module-level definitions (not lexical bindings). So
;; they are useful for things like imenu. Also these are a good
@@ -231,7 +231,8 @@
(match keys
[(list key) (hash-set! ht key (add1 beg))]
[(cons key more) (trie-set! (hash-ref! ht key (make-hash)) more)]))
- (set-add! local-completion-candidates (~a symbol)))
+ (set-add! local-completion-candidates
+ (~a symbol)))
(define/override (syncheck:add-jump-to-definition _src beg end id-sym path
submods)
;; - drracket/check-syntax only reports the file, not the
diff --git a/racket/imports.rkt b/racket/imports.rkt
index 8f95115375..44b6de44b5 100644
--- a/racket/imports.rkt
+++ b/racket/imports.rkt
@@ -37,8 +37,19 @@
;; It is important to run this with the correct parameterization of
;; current-namespace and current-load-relative-directory.
-(define/contract (imports stx [sos (mutable-set)])
- (->* (syntax?) (set-mutable?) set-mutable?)
+(define/contract (imports stx)
+ (->* (syntax?) hash?)
+ (define ht (make-hash))
+ (define (update! rmp f)
+ (hash-update! ht (->str rmp) f (set)))
+ (define (add! rmp v)
+ (update! rmp (λ (s) (set-add s (->str v)))))
+ (define (remove! rmp v)
+ (update! rmp (λ (s) (set-remove s (->str v)))))
+ (define (add-set! rmp set-of-strings)
+ (update! rmp (λ (s) (set-union s set-of-strings))))
+ (define (remove-set! rmp set-of-strings)
+ (update! rmp (λ (s) (set-subtract s set-of-strings))))
(define (handle-module stx)
(syntax-case stx (module #%module-begin #%plain-module-begin)
@@ -99,9 +110,9 @@
(define (handle-phaseless-spec spec lang)
(syntax-case* spec (only prefix all-except prefix-all-except rename)
symbolic-compare?
- [(only _raw-module-path id ...)
- (set-union! sos
- (syntax->string-set #'(id ...)))]
+ [(only raw-module-path id ...)
+ (add-set! #'raw-module-path
+ (syntax->string-set (syntax->list #'(id ...))))]
[(prefix prefix-id raw-module-path)
(module-exported-strings #'raw-module-path
lang
@@ -118,8 +129,8 @@
[(rename raw-module-path local-id exported-id)
(begin
(unless (eq? (syntax-e #'raw-module-path) (syntax-e lang))
- (set-remove! sos (->str #'exported-id)))
- (set-add! sos (->str #'local-id)))]
+ (remove! #'raw-module-path #'exported-id))
+ (add! #'raw-module-path #'local-id))]
[raw-module-path
(module-path? (syntax->datum #'raw-module-path))
(module-exported-strings #'raw-module-path
@@ -128,7 +139,7 @@
(define (module-exported-strings raw-module-path
lang
#:except [exceptions (set)]
- #:prefix [prefix #'""])
+ #:prefix [prefix #f])
;; NOTE: Important to run module->exports with the correct
;; parameterization of current-namespace and
;; current-load-relative-directory.
@@ -138,25 +149,28 @@
;; completion candidates from drracket/check-syntax for
;; non-imported bindings. Our contribution is imported
;; definitions.
- (with-handlers ([exn:fail? (λ _ sos)])
- (define-values (vars stxs)
- (module->exports (syntax->datum raw-module-path)))
+ (define-values (vars stxs)
+ (with-handlers ([exn:fail? (λ _ (values #f #f))])
+ (module->exports (syntax->datum raw-module-path))))
+ (when (and vars stxs)
(define orig
- (for*/mutable-set ([vars+stxs (in-list (list vars stxs))]
- [phases (in-list vars+stxs)]
- [export (in-list (cdr phases))])
+ (for*/set ([vars+stxs (in-list (list vars stxs))]
+ [phases (in-list vars+stxs)]
+ [export (in-list (cdr phases))])
(->str (car export))))
;; If imports are from the module language, then {except rename
;; prefix}-in do NOT remove imports under the original name.
;; Otherwise they do.
(if (eq? (syntax-e raw-module-path) (syntax-e lang))
- (set-union! sos orig)
- (set-subtract! sos orig exceptions))
- (for ([v (in-set orig)])
- (set-add! sos (~a (->str prefix) v)))))
+ (add-set! raw-module-path orig)
+ (remove-set! raw-module-path exceptions))
+ (if prefix
+ (for ([v (in-set orig)])
+ (add! raw-module-path (~a prefix (->str v))))
+ (add-set! raw-module-path orig))))
(handle-module stx)
- sos)
+ ht)
(define (->str v)
(match v
@@ -165,7 +179,7 @@
[(? string?) v]))
(define (syntax->string-set s)
- (for/mutable-set ([s (in-syntax s)])
+ (for/set ([s (in-syntax s)])
(->str s)))
(define (symbolic-compare? x y)
@@ -187,13 +201,13 @@
(module+ completions-example-2
(require "syntax.rkt")
(parameterize ([current-namespace (make-base-empty-namespace)])
- (string->expanded-syntax "/tmp/foo.rkt" "#lang rhombus\n1"
+ (string->expanded-syntax "/tmp/foo.rkt" "#lang rhombus\n"
imports)))
(module+ test
(require rackunit
version/utils)
- ;; Compare the results to namespace-mapped-symbols.
+ ;; To compare the results to namespace-mapped-symbols.
(module mod racket/base
(module sub racket/base
(define provided-by-submodule 42)
@@ -236,17 +250,17 @@
;; Test {prefix rename except}-in, keeping mind that they work
;; differently for requires that modify the module language
;; imports.
- (check-false (set-member? cs "path-only")
+ (check-false (set-member? (hash-ref cs "racket/path") "path-only")
"rename-in not from module language hides old name")
- (check-true (set-member? cs "PATH-ONLY")
+ (check-true (set-member? (hash-ref cs "racket/path") "PATH-ONLY")
"rename-in not from module language has new name ")
- (check-true (set-member? cs "display")
+ (check-true (set-member? (hash-ref cs "racket/base") "display")
"rename-in from module language does not hide old name")
- (check-true (set-member? cs "DISPLAY")
+ (check-true (set-member? (hash-ref cs "racket/base") "DISPLAY")
"rename-in from module language has new name")
- (check-true (set-member? cs "displayln")
+ (check-true (set-member? (hash-ref cs "racket/base") "displayln")
"prefix-in from module language does not hide old name")
- (check-true (set-member? cs "PREFIX:displayln")
+ (check-true (set-member? (hash-ref cs "racket/base") "PREFIX:displayln")
"prefix-in from module language is available under new name")
;; namespace-mapped-symbols will return some definitions beyond
;; those imported -- it includes {top module}-level bindings. This
@@ -259,7 +273,7 @@
;; Well, _our_ results are correct. For now, let's just do the
;; test on Racket 7.0+.
(when (version<=? "7.0" (version))
- (check-equal? (set-subtract nsms cs)
+ (check-equal? (set-subtract nsms (apply set-union (hash-values cs)))
(set "tmp.1" "nsms" "nsa" "provided-by-submodule")
"namespace-mapped-symbols returns only a few more,
non-imported definitions")))
;; Issue 481