From 791d8759eb9b230f103f978dedaa7befa9fc68eb Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Thu, 18 Jan 2024 19:59:57 +0100 Subject: [PATCH] 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 fdc7d68101e..bfc7f6d5985 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1619,6 +1619,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 a6f14a0865c..7fbf04d98c1 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) -- 2.39.2