[nongnu] elpa/racket-mode 5bade9bbea 2/4: Improve completion for hash-langs; support completion categories

[ELPA Syncer]

branch: elpa/racket-mode
commit 5bade9bbeaa650ee56513673c5c9522ed9d0c616
Author: Greg Hendershott <git@greghendershott.com>
Commit: Greg Hendershott <git@greghendershott.com>

    Improve completion for hash-langs; support completion categories
    
    Use value of forward-sexp-function as a signal whether to assume sexps
    for completion boundaries and whether to check for being inside a
    racket-lang require form.
    
    Have our completion tables supply "category" metadata. This allows the
    user to configure completion matching styles (e.g. "basic", "flex",
    and others) appropriate to the kind of thing being completed.
---
 racket-complete.el    | 68 ++++++++++++++++++++++++++++++++++++++-------------
 racket-edit.el        | 22 ++++++++---------
 racket-repl.el        |  6 +----
 racket-xp-complete.el | 11 +++------
 4 files changed, 65 insertions(+), 42 deletions(-)

diff --git a/racket-complete.el b/racket-complete.el
index 0ddd08d780..9ab89d14b9 100644
--- a/racket-complete.el
+++ b/racket-complete.el
@@ -1,6 +1,6 @@
 ;;; racket-complete.el -*- lexical-binding: t -*-
 
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2023 by Greg Hendershott.
 ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
 
 ;; Author: Greg Hendershott
@@ -11,6 +11,14 @@
 (require 'racket-common)
 
 (defun racket--call-with-completion-prefix-positions (proc)
+  (if forward-sexp-function ;not necessarily sexp lang
+      (condition-case nil
+          (save-excursion
+            (let ((beg (progn (forward-sexp -1) (point)))
+                  (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)) '(?\" ?\( ?\))))
@@ -19,25 +27,51 @@
             (goto-char beg)
             (forward-sexp 1)
             (let ((end (point)))
-              (and
-               (<= (+ beg 2) end) ;prefix at least 2 chars
+              (when (<= (+ beg 2) end) ;prefix at least 2 chars
                (funcall proc beg end))))
-        (scan-error nil)))))
+        (error nil)))))
 
 (defun racket--in-require-form-p ()
-  (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))))
+  (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)))
+
+(defun racket--completion-table (completions &optional category)
+  "Like `completion-table-dynamic' but we supply category metadata.
+
+CATEGORY defaults to `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.
+
+Supplying category metadata allows the user to configure a
+completion matching style for that category."
+  (let ((category (or category racket--identifier-category)))
+    (lambda (prefix predicate action)
+      (if (eq action 'metadata)
+          `(metadata (category . ,category))
+        (complete-with-action action completions prefix predicate)))))
 
 (provide 'racket-complete)
 
diff --git a/racket-edit.el b/racket-edit.el
index f4475c8c92..3a0b07d398 100644
--- a/racket-edit.el
+++ b/racket-edit.el
@@ -436,16 +436,15 @@ When LISTP is true, expects couples to be `[id val]`, 
else `id val`."
 
 ;;; Completion
 
-(defvar racket--completion-candidates (list racket-type-list
-                                            racket-keywords
-                                            racket-builtins-1-of-2
-                                            racket-builtins-2-of-2))
-
-(defun racket--completion-candidates-for-prefix (prefix)
-  (cl-reduce (lambda (results strs)
-               (append results (all-completions prefix strs)))
-             racket--completion-candidates
-             :initial-value ()))
+(defconst racket--completion-candidates
+  (seq-sort #'string-lessp
+            (seq-reduce (lambda (accum xs)
+                          (append accum xs))
+                        (list racket-type-list
+                              racket-keywords
+                              racket-builtins-1-of-2
+                              racket-builtins-2-of-2)
+                        nil)))
 
 (defun racket-complete-at-point ()
   "A value for the variable `completion-at-point-functions'.
@@ -457,8 +456,7 @@ completion candidates, enable the minor mode 
`racket-xp-mode'."
    (lambda (beg end)
      (list beg
            end
-           (completion-table-dynamic
-            #'racket--completion-candidates-for-prefix)
+           (racket--completion-table racket--completion-candidates)
            :predicate #'identity
            :exclusive 'no))))
 
diff --git a/racket-repl.el b/racket-repl.el
index 79d4dfdd7f..b878aa3eac 100644
--- a/racket-repl.el
+++ b/racket-repl.el
@@ -1108,9 +1108,6 @@ image."
 
 (add-hook 'racket--repl-after-run-hook   
#'racket--repl-refresh-namespace-symbols)
 
-(defun racket--repl-completion-candidates-for-prefix (prefix)
-  (all-completions prefix racket--repl-namespace-symbols))
-
 (defun racket-repl-complete-at-point ()
   "A value for the variable `completion-at-point-functions'.
 
@@ -1124,8 +1121,7 @@ to supply this quickly enough or at all."
    (lambda (beg end)
      (list beg
            end
-           (completion-table-dynamic
-            #'racket--repl-completion-candidates-for-prefix)
+           (racket--completion-table racket--repl-namespace-symbols)
            :predicate #'identity
            :exclusive 'no
            :company-doc-buffer #'racket--repl-company-doc-buffer
diff --git a/racket-xp-complete.el b/racket-xp-complete.el
index 50d5d1b8b8..e5324e8deb 100644
--- a/racket-xp-complete.el
+++ b/racket-xp-complete.el
@@ -51,10 +51,7 @@ Set by `racket-xp-mode'. Used by 
`racket-xp-complete-at-point'.")
 (defun racket--xp-capf-bindings (beg end)
   (list beg
         end
-        (completion-table-dynamic
-         (lambda (prefix)
-           (all-completions prefix racket--xp-binding-completions)))
-        :predicate          #'identity
+        (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)))
@@ -73,9 +70,7 @@ that are require transformers."
 (defun racket--xp-capf-absolute-module-paths (beg end)
   (list beg
         end
-        (completion-table-dynamic
-         (lambda (prefix)
-           (all-completions prefix racket--xp-module-completions)))
+        (racket--completion-table racket--xp-module-completions)
         :exclusive 'no))
 
 (defun racket--xp-capf-relative-module-paths ()
@@ -89,7 +84,7 @@ that are require transformers."
                                 table)))
             (list beg
                   end
-                  table
+                  (racket--completion-table table 'file)
                   :exclusive 'no))))))))
 
 (defun racket--xp-make-company-location-proc ()