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.

diff --git a/etc/NEWS b/etc/NEWS
index a0b459dce5f26efa5bc8791017db5a52a0303872..d174e00d04afa6d4ca7b686fa35449fe4ccfcbb9 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1657,6 +1657,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 3e7970aaa3e0e936a0535efcdc52f4d6d65d3e05..5f776829d7d87af955205c3a1cbfaca4337ea95b 100644 (file)
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -559,14 +559,11 @@ 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)
-                               (narrow-completions-function
-                                . bookmark-narrow-completions-by-type))
-                             (complete-with-action
-                              action bookmark-alist string pred)))
+                       (completion-table-with-metadata
+                        bookmark-alist
+                        '((category . bookmark)
+                          (narrow-completions-function
+                           . bookmark-narrow-completions-by-type)))
                        nil 0 nil 'bookmark-history default))))
 
 (defun bookmark-narrow-completions-by-type ()

diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el
index 3a191c5ecd35acf6bbfccaf2ad071f9d39e43e18..3b97d6915af7b872c339cd48a8c34323a4160cd0 100644 (file)
--- 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 07f11a62594db161ec897f8391950f9c4f2cb177..083af430e6f7392f5f1b96b4ca92db4d719c4c0b 100644 (file)
--- 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 fe8d513c19582e09bc9a6483cd31cf15fed7dba8..8e7c302c6a32018bdb3f58d1c8be8bd573b111ef 100644 (file)
--- 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
@@ -2793,17 +2817,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.
 
@@ -2842,7 +2855,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)
@@ -4077,22 +4094,19 @@ See `read-file-name' for the meaning of the arguments."
          (name
           (completing-read
            "Restrict to mode: "
-           (lambda (string pred action)
-             (if (eq action 'metadata)
-                 (list 'metadata
-                       (cons
-                        'annotation-function
-                        (lambda (cand)
-                          (let* ((sym (intern (concat cand "-mode")))
-                                 (doc (ignore-errors (documentation sym))))
-                            (when doc
-                              (concat
-                               (make-string
-                                (- (+ max 2) (string-width cand)) ?\s)
-                               (propertize
-                                (substring doc 0 (string-search "\n" doc))
-                                'face 'completions-annotations)))))))
-               (complete-with-action action modes string pred)))
+           (completion-table-with-metadata
+            modes (list (cons
+                         'annotation-function
+                         (lambda (cand)
+                           (let* ((sym (intern (concat cand "-mode")))
+                                  (doc (ignore-errors (documentation sym))))
+                             (when doc
+                               (concat
+                                (make-string
+                                 (- (+ max 2) (string-width cand)) ?\s)
+                                (propertize
+                                 (substring doc 0 (string-search "\n" doc))
+                                 'face 'completions-annotations))))))))
            nil t))
          (mode (intern (concat name "-mode"))))
     (cons
@@ -5403,11 +5417,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.
@@ -5423,11 +5435,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 a6f14a0865c6611052221fba18241a021b41b171..7fbf04d98c199e567e1d4d1ab7a06d48016d6746 100644 (file)
--- 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 717b837a2e59676c3e9e8256c5d81dcdb0aed7a8..c4364a8b464360fd8799760d6b576e7413c779ca 100644 (file)
--- 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/recentf.el b/lisp/recentf.el
index 4c8b852197a405833ad0aa1f58a657842e64f321..b236eea2be948b7ab092dd1fdb92ecd80c977e4c 100644 (file)
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -484,23 +484,6 @@ Return non-nil if F1 is less than F2."
 ;;; Open files
 ;;
 
-(defun recentf-completion-table (string pred action)
-  "Completion table for recent file names.
-
-See Info node `(elisp)Programmed Completion' for the meaning of
-STRING, PRED and ACTION."
-  (if (eq action 'metadata)
-      `(metadata
-        ;; Report `recent-file' rather than `file' as the category, so
-        ;; users can configure the two separately.
-        (category . recent-file)
-        ;; Sort candidates by their position in `recentf-list'.
-        (cycle-sort-function   . identity)
-        (display-sort-function . identity)
-        ,@(when completions-detailed
-            '((affixation-function . completion-file-name-affixation))))
-    (complete-with-action action recentf-list string pred)))
-
 ;;;###autoload
 (defun recentf-open (file)
   "Open recently visited FILE.
@@ -510,8 +493,19 @@ is not already on."
   (interactive
    (progn
      (unless recentf-mode (recentf-mode 1))
-     (list (completing-read "Open recent file: "
-                            #'recentf-completion-table nil 'confirm))))
+     (list (completing-read
+            "Open recent file: "
+            (completion-table-with-metadata
+             recentf-list
+             `(;; Report `recent-file' rather than `file' as the
+               ;; category, so users can configure the two separately.
+               (category . recent-file)
+               ;; Sort candidates by their position in `recentf-list'.
+               (cycle-sort-function   . identity)
+               (display-sort-function . identity)
+               ,@(when completions-detailed
+                   '((affixation-function . completion-file-name-affixation)))))
+            nil 'confirm))))
   (funcall recentf-menu-action file))
 
 ;;;###autoload

diff --git a/lisp/simple.el b/lisp/simple.el
index 6faeeba125a7a6ccfbede9df6ac69b6c64fed05a..42f2ae24696dcc3bfd55a432ea3fa21d1e949890 100644 (file)
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -6548,11 +6548,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 f52afb7e1624c2d1742c252fe0ee64c3ac600d69..8c0f192322a4f1cc2870cc7cfa02eeb7b1a1e48f 100644 (file)
--- 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)