Complete shorthands to longhands for symbol-completing tablesscratch/bug-50959-fix

Shorthands aren't symbols, they're text forms that 'read' into
symbols.  As such, shorthands aren't candidates in these tables of
symbols.  But in some situations, if no other candidates match the
pattern, we can e.g. complete "x-foo" to "xavier-foo" if the shorthand

  (("x-" . "xavier-"))

is set up in the buffer of origin.

bug#50959

* lisp/help-fns.el (help--symbol-completion-table): Report
`symbol-help' category.

* lisp/minibuffer.el (completion-styles-alist): New 'shorthand'
style.
(completion-category-defaults): Link 'symbol-help' category with
'shorthand' style.
(minibuffer--original-buffer): New variable.
(completing-read-default): Setup minibuffer--original-buffer.
(completion-shorthand-try-completion)
(completion-shorthand-all-completions): New helpers.

2 files changed, 53 insertions, 5 deletions

diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 6be5cd4a501..03bbc979a9c 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -176,8 +176,11 @@ with the current prefix.  The files are chosen according to
           completions))
 
 (defun help--symbol-completion-table (string pred action)
-  (if (and completions-detailed (eq action 'metadata))
-      '(metadata (affixation-function . help--symbol-completion-table-affixation))
+  (if (eq action 'metadata)
+      `(metadata
+        ,@(when completions-detailed
+            '((affixation-function . help--symbol-completion-table-affixation)))
+        (category . symbol-help))
     (when help-enable-completion-autoload
       (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string)))
         (help--load-prefixes prefixes)))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 1e1a6f852e8..48859585bc2 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -943,7 +943,12 @@ When completing \"foo\" the glob \"*f*o*o*\" is used, so that
      completion-initials-try-completion completion-initials-all-completions
      "Completion of acronyms and initialisms.
 E.g. can complete M-x lch to list-command-history
-and C-x C-f ~/sew to ~/src/emacs/work."))
+and C-x C-f ~/sew to ~/src/emacs/work.")
+    (shorthand
+     completion-shorthand-try-completion completion-shorthand-all-completions
+     "Completion of symbol shorthands setup in `read-symbol-shorthands'.
+E.g. can complete \"x-foo\" to \"xavier-foo\" if the shorthand
+((\"x-\" . \"xavier-\")) is set up in the buffer of origin."))
   "List of available completion styles.
 Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC):
 where NAME is the name that should be used in `completion-styles',
@@ -990,7 +995,8 @@ styles for specific categories, such as files, buffers, etc."
     ;; e.g. one that does not anchor to bos.
     (project-file (styles . (substring)))
     (xref-location (styles . (substring)))
-    (info-menu (styles . (basic substring))))
+    (info-menu (styles . (basic substring)))
+    (symbol-help (styles . (basic shorthand substring))))
   "Default settings for specific completion categories.
 Each entry has the shape (CATEGORY . ALIST) where ALIST is
 an association list that can specify properties such as:
@@ -1618,6 +1624,9 @@ DONT-CYCLE tells the function not to setup cycling."
 (defvar minibuffer--require-match nil
   "Value of REQUIRE-MATCH passed to `completing-read'.")
 
+(defvar minibuffer--original-buffer nil
+  "Buffer that was current when `completing-read' was called.")
+
 (defun minibuffer-complete-and-exit ()
   "Exit if the minibuffer contains a valid completion.
 Otherwise, try to complete the minibuffer contents.  If
@@ -4080,6 +4089,40 @@ which is at the core of flex logic.  The extra
   (let ((newstr (completion-initials-expand string table pred)))
     (when newstr
       (completion-pcm-try-completion newstr table pred (length newstr)))))
+
+;; Shorthand completion
+;;
+;; Iff there is a (("x-" . "string-library-")) shorthand setup and
+;; string-library-foo is in candidates, complete x-foo to it.
+
+(defun completion-shorthand-try-completion (string table pred point)
+  "Try completion with `read-symbol-shorthands' of original buffer."
+  (cl-loop with expanded
+           for (short . long) in
+           (with-current-buffer minibuffer--original-buffer
+             read-symbol-shorthands)
+           for probe =
+           (and (> point (length short))
+                (string-prefix-p short string)
+                (try-completion (setq expanded
+                                      (concat long
+                                              (substring
+                                               string
+                                               (length short))))
+                                table pred))
+           when probe
+           do (message "Shorthand expansion")
+           and return (cons expanded (max (length long)
+                                          (+ (- point (length short))
+                                             (length long))))))
+
+(defun completion-shorthand-all-completions (string table pred _point)
+  ;; no-op: For now, we don't want shorthands to list all the possible
+  ;; locally active longhands.  For the completion categories where
+  ;; this style is active, it could hide other more interesting
+  ;; matches from subsequent styles.
+  nil)
+
 
 (defvar completing-read-function #'completing-read-default
   "The function called by `completing-read' to do its work.
@@ -4111,6 +4154,7 @@ See `completing-read' for the meaning of the arguments."
                     ;; in minibuffer-local-filename-completion-map can
                     ;; override bindings in base-keymap.
                     base-keymap)))
+         (buffer (current-buffer))
          (result
           (minibuffer-with-setup-hook
               (lambda ()
@@ -4119,7 +4163,8 @@ See `completing-read' for the meaning of the arguments."
                 ;; FIXME: Remove/rename this var, see the next one.
                 (setq-local minibuffer-completion-confirm
                             (unless (eq require-match t) require-match))
-                (setq-local minibuffer--require-match require-match))
+                (setq-local minibuffer--require-match require-match)
+                (setq-local minibuffer--original-buffer buffer))
             (read-from-minibuffer prompt initial-input keymap
                                   nil hist def inherit-input-method))))
     (when (and (equal result "") def)