feature/minibuffer-completion-enhancements 370936bef90 23/35: New helper function for creating completion tables with metadata

[Eshel Yaron]

branch: feature/minibuffer-completion-enhancements
commit 370936bef904e7ad42d6bb019b12322c67e8d267
Author: Eshel Yaron <me@eshelyaron.com>
Commit: Eshel Yaron <me@eshelyaron.com>

    New helper function for creating completion tables with metadata
    
    * lisp/minibuffer.el (completion-styles-table): Remove in favor of...
    (completion-table-with-metadata): New function.
    (minibuffer-set-completion-styles)
    (minibuffer-narrow-buffer-completions)
    (minibuffer-complete-history, minibuffer-complete-defaults)
    * lisp/bookmark.el (bookmark-completing-read)
    * lisp/international/emoji.el (emoji--read-emoji)
    * lisp/international/mule-cmds.el (read-char-by-name)
    * lisp/progmodes/project.el (project--file-completion-table)
    * lisp/progmodes/xref.el (xref-show-definitions-completing-read)
    * lisp/recentf.el (recentf-open)
    * lisp/simple.el (read-from-kill-ring)
    * lisp/tmm.el (tmm--completion-table): Use it.
    
    * etc/NEWS: Announce it.
---
 etc/NEWS                        |  4 +++
 lisp/bookmark.el                |  7 ++---
 lisp/international/emoji.el     | 35 ++++++++++++-------------
 lisp/international/mule-cmds.el | 22 +++++++---------
 lisp/minibuffer.el              | 57 +++++++++++++++++++++++++----------------
 lisp/progmodes/project.el       |  7 +----
 lisp/progmodes/xref.el          | 12 +++------
 lisp/simple.el                  |  7 ++---
 lisp/tmm.el                     |  5 +---
 9 files changed, 74 insertions(+), 82 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index fa736510919..80c154e10d0 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1631,6 +1631,10 @@ styles to skip eager fontification of completion 
candidates, which
 improves performance.  Such a Lisp program can then use the
 'completion-lazy-hilit' function to fontify candidates just in time.
 
+---
+** New function 'completion-table-with-metadata'.
+This function returns a completion table with additional metadata.
+
 ** Functions and variables to transpose sexps
 
 +++
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 60dd61a5ac8..eea4bbe7abb 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -559,11 +559,8 @@ If DEFAULT is nil then return empty string for empty 
input."
     (let* ((completion-ignore-case bookmark-completion-ignore-case)
            (default (unless (equal "" default) default)))
       (completing-read (format-prompt prompt default)
-                       (lambda (string pred action)
-                         (if (eq action 'metadata)
-                             '(metadata (category . bookmark))
-                             (complete-with-action
-                              action bookmark-alist string pred)))
+                       (completion-table-with-metadata
+                        bookmark-alist '((category . bookmark)))
                        nil 0 nil 'bookmark-history default))))
 
 
diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el
index 3a191c5ecd3..3b97d6915af 100644
--- a/lisp/international/emoji.el
+++ b/lisp/international/emoji.el
@@ -663,25 +663,22 @@ We prefer the earliest unique letter."
          (name
           (completing-read
            "Insert emoji: "
-           (lambda (string pred action)
-            (if (eq action 'metadata)
-                (list 'metadata
-                      (cons
-                        'affixation-function
-                        ;; Add the glyphs to the start of the displayed
-                        ;; strings when TAB-ing.
-                        (lambda (strings)
-                          (mapcar
-                           (lambda (name)
-                             (if emoji-alternate-names
-                                 (list name "" "")
-                               (list name
-                                     (concat
-                                      (or (gethash name emoji--all-bases) " ")
-                                      "\t")
-                                     "")))
-                           strings))))
-              (complete-with-action action table string pred)))
+           (completion-table-with-metadata
+            table (list (cons
+                         'affixation-function
+                         ;; Add the glyphs to the start of the displayed
+                         ;; strings when TAB-ing.
+                         (lambda (strings)
+                           (mapcar
+                            (lambda (name)
+                              (if emoji-alternate-names
+                                  (list name "" "")
+                                (list name
+                                      (concat
+                                       (or (gethash name emoji--all-bases) " ")
+                                       "\t")
+                                      "")))
+                            strings)))))
            nil t)))
     (when (cl-plusp (length name))
       (let ((glyph (if emoji-alternate-names
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 07f11a62594..083af430e6f 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -3238,22 +3238,18 @@ single characters to be treated as standing for 
themselves."
   (let* ((enable-recursive-minibuffers t)
         (completion-ignore-case t)
         (completion-tab-width 4)
+         (sort-fun (when (eq read-char-by-name-sort 'code)
+                    #'mule--ucs-names-sort-by-code))
+         (group-fun (when completions-group #'mule--ucs-names-group))
         (input
          (completing-read
           prompt
-          (lambda (string pred action)
-            (if (eq action 'metadata)
-                `(metadata
-                  (display-sort-function
-                   . ,(when (eq read-char-by-name-sort 'code)
-                        #'mule--ucs-names-sort-by-code))
-                  (affixation-function
-                   . ,#'mule--ucs-names-affixation)
-                  (group-function
-                   . ,(when completions-group
-                        #'mule--ucs-names-group))
-                  (category . unicode-name))
-              (complete-with-action action (ucs-names) string pred)))))
+           (completion-table-with-metadata
+            (ucs-names)
+            `((display-sort-function . ,sort-fun)
+             (affixation-function . ,#'mule--ucs-names-affixation)
+             (group-function . ,group-fun)
+             (category . unicode-name)))))
         (char
           (cond
            ((char-from-name input t))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index c0d656d5771..58d6f74d96c 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -618,6 +618,30 @@ for use at QPOS."
                                             unquoted-result base
                                             unquote requote))))))))))))
 
+(defun completion-table-with-metadata (table metadata)
+  "Return completion TABLE with additional METADATA.
+
+METADATA is a completion metatdata alist.  See
+`completion-metadata' for a description of its possible values.
+METADATA can also be a function that takes two arguments, STRING
+and PRED, and returns a metadata alist appropriate for completing
+STRING subject to predicate PRED.
+
+METADATA takes precedence over any metadata that TABLE provides."
+  (let ((md-fun (if (functionp metadata)
+                    metadata
+                  (lambda (&rest _) metadata))))
+    (lambda (string pred action)
+      (cond
+       ((eq action 'metadata)
+        (cons 'metadata
+              (append (funcall md-fun string pred)
+                      (cdr-safe (completion-metadata string table pred)))))
+       ((eq (car-safe action) 'boundaries)
+        (completion-boundaries string table pred (cdr action)))
+       (t
+        (complete-with-action action table string pred))))))
+
 (defun completion--twq-try (string ustring completion point
                                    unquote requote)
   ;; Basically two cases: either the new result is
@@ -2792,17 +2816,6 @@ current order instead."
                "")))
      names)))
 
-(defun completion-styles-table (string pred action)
-  "Completion table for completion styles.
-
-See Info node `(elisp)Programmed Completion' for the meaning of
-STRING, PRED and ACTION."
-  (if (eq action 'metadata)
-      '(metadata
-        (category . completion-style)
-        (affixation-function . completion-styles-affixation))
-    (complete-with-action action completion-styles-alist string pred)))
-
 (defun minibuffer-set-completion-styles (styles)
   "Set the completion styles for the current minibuffer to STYLES.
 
@@ -2841,7 +2854,11 @@ completions list."
                        (setq-local crm-separator "[ \t]*,[ \t]*"))
                    (completing-read-multiple
                     "Set completion styles: "
-                    #'completion-styles-table nil t
+                    (completion-table-with-metadata
+                     completion-styles-alist
+                     '((category . completion-style)
+                       (affixation-function . completion-styles-affixation)))
+                    nil t
                     (concat (mapconcat #'symbol-name styles ",") ","))))))))
    minibuffer-mode)
   (setq-local completion-local-styles styles)
@@ -5232,11 +5249,9 @@ instead of the default completion table."
            (lambda () (get-buffer-window "*Completions*" 0))))
       (completion-in-region
        (minibuffer--completion-prompt-end) (point-max)
-       (lambda (string pred action)
-         (if (eq action 'metadata)
-             '(metadata (display-sort-function . identity)
-                        (cycle-sort-function . identity))
-           (complete-with-action action completions string pred)))))))
+       (completion-table-with-metadata
+        completions '((display-sort-function . identity)
+                      (cycle-sort-function   . identity)))))))
 
 (defun minibuffer-complete-defaults ()
   "Complete minibuffer defaults as far as possible.
@@ -5252,11 +5267,9 @@ instead of the completion table."
          (lambda () (get-buffer-window "*Completions*" 0))))
     (completion-in-region
      (minibuffer--completion-prompt-end) (point-max)
-     (lambda (string pred action)
-       (if (eq action 'metadata)
-           '(metadata (display-sort-function . identity)
-                      (cycle-sort-function . identity))
-         (complete-with-action action completions string pred))))))
+     (completion-table-with-metadata
+      completions '((display-sort-function . identity)
+                    (cycle-sort-function   . identity))))))
 
 (define-key minibuffer-local-map [?\C-x up] 'minibuffer-complete-history)
 (define-key minibuffer-local-map [?\C-x down] 'minibuffer-complete-defaults)
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index ab4504fa027..325e207b70d 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -312,12 +312,7 @@ end it with `/'.  DIR must be either `project-root' or one 
of
    grep-find-ignored-files))
 
 (defun project--file-completion-table (all-files)
-  (lambda (string pred action)
-    (cond
-     ((eq action 'metadata)
-      '(metadata . ((category . project-file))))
-     (t
-      (complete-with-action action all-files string pred)))))
+  (completion-table-with-metadata all-files '((category . project-file))))
 
 (cl-defmethod project-root ((project (head transient)))
   (cdr project))
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 717b837a2e5..c4364a8b464 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1413,14 +1413,10 @@ between them by typing in the minibuffer with 
completion."
                    (car xrefs)
                  (let* ((collection (reverse xref-alist-with-line-info))
                         (ctable
-                         (lambda (string pred action)
-                           (cond
-                            ((eq action 'metadata)
-                             `(metadata
-                               . ((category . xref-location)
-                                  (group-function . 
,#'xref--completing-read-group))))
-                            (t
-                             (complete-with-action action collection string 
pred)))))
+                         (completion-table-with-metadata
+                          collection
+                          '((category . xref-location)
+                            (group-function . 
,#'xref--completing-read-group))))
                         (def (caar collection)))
                    (cdr (assoc (completing-read "Choose definition: "
                                                 ctable nil t
diff --git a/lisp/simple.el b/lisp/simple.el
index 4c95332f2b8..b80c0e2447f 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -6450,11 +6450,8 @@ PROMPT is a string to prompt with."
              map)))
       (completing-read
        prompt
-       (lambda (string pred action)
-         (if (eq action 'metadata)
-             ;; Keep sorted by recency
-             '(metadata (display-sort-function . identity))
-           (complete-with-action action completions string pred)))
+       (completion-table-with-metadata
+        completions '((display-sort-function . identity)))
        nil nil nil
        (if history-pos
            (cons 'read-from-kill-ring-history
diff --git a/lisp/tmm.el b/lisp/tmm.el
index f52afb7e162..8c0f192322a 100644
--- a/lisp/tmm.el
+++ b/lisp/tmm.el
@@ -115,10 +115,7 @@ specify nil for this variable."
   "Face used for inactive menu items.")
 
 (defun tmm--completion-table (items)
-  (lambda (string pred action)
-    (if (eq action 'metadata)
-       '(metadata (display-sort-function . identity))
-      (complete-with-action action items string pred))))
+  (completion-table-with-metadata items '((display-sort-function . identity))))
 
 (defvar tmm--history nil)