From: Eshel Yaron Date: Thu, 18 Jan 2024 18:59:57 +0000 (+0100) Subject: New helper function for creating completion tables with metadata X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=1bd4e003660278c5d085d87199d2a31376dd4ff3;p=emacs.git 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 a0b459dce5f..d174e00d04a 100644 --- 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 3e7970aaa3e..5f776829d7d 100644 --- 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 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 fe8d513c195..8e7c302c6a3 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 @@ -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 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/recentf.el b/lisp/recentf.el index 4c8b852197a..b236eea2be9 100644 --- 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 6faeeba125a..42f2ae24696 100644 --- 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 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)