diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 170f497541..de4005d6cd 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -127,16 +127,45 @@ help-enable-completion-autoload :version "26.3") (defun help--symbol-completion-table (string pred action) - (when help-enable-completion-autoload - (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string))) - (help--load-prefixes prefixes))) - (let ((prefix-completions - (and help-enable-completion-autoload - (mapcar #'intern (all-completions string definition-prefixes))))) - (complete-with-action action obarray string - (if pred (lambda (sym) - (or (funcall pred sym) - (memq sym prefix-completions))))))) + (if (eq action 'metadata) + (when completions-detailed + '(metadata + (affix-function + . (lambda (completions) + (mapcar (lambda (c) + (let* ((s (intern c)) + (doc (condition-case nil (documentation s) (error nil))) + (doc (and doc (substring doc 0 (string-match "\n" doc))))) + (list c (concat (cond ((commandp s) + "c") + ((eq (car-safe (symbol-function s)) 'macro) + "m") + ((fboundp s) + "f") + ((custom-variable-p s) + "u") ; user option + ((boundp s) + "v") + ((facep s) + "a") + ((and (fboundp 'cl-find-class) + (cl-find-class s)) + "t") ; CL type + (" ")) + " ") + (if doc (format " -- %s" doc) "")))) + completions))))) + + (when help-enable-completion-autoload + (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string))) + (help--load-prefixes prefixes))) + (let ((prefix-completions + (and help-enable-completion-autoload + (mapcar #'intern (all-completions string definition-prefixes))))) + (complete-with-action action obarray string + (if pred (lambda (sym) + (or (funcall pred sym) + (memq sym prefix-completions)))))))) (defvar describe-function-orig-buffer nil "Buffer that was current when `describe-function' was invoked. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 9d57a817b2..7e1d806059 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -83,7 +80,6 @@ ;; - add support for ** to pcm. ;; - Add vc-file-name-completion-table to read-file-name-internal. -;; - A feature like completing-help.el. ;;; Code: @@ -121,6 +117,9 @@ completion-metadata - `annotation-function': function to add annotations in *Completions*. Takes one argument (STRING), which is a possible completion and returns a string to append to STRING. +- `affix-function': function to prepend/append a prefix/suffix to entries. + Takes one argument (COMPLETIONS) and should return a list + of completions with a completion, its prefix and suffix. - `display-sort-function': function to sort entries in *Completions*. Takes one argument (COMPLETIONS) and should return a new list of completions. Can operate destructively. @@ -1669,7 +1668,7 @@ completion-in-region--single-word (#b000 nil) (_ t)))) -(defface completions-annotations '((t :inherit italic)) +(defface completions-annotations '((t :inherit (italic shadow))) "Face to use for annotations in the *Completions* buffer.") (defcustom completions-format 'horizontal @@ -1681,6 +1680,16 @@ completions-format :type '(choice (const horizontal) (const vertical)) :version "23.2") +(defcustom completions-detailed nil + "When non-nil, display completions vertically with one completion per row. +This option overrides another related option `completions-format'. +Some commands might provide a detailed view with more information added +to completions. When the used completion function doesn't provide +a detailed view via `affix-function', then fall back to the value +defined by `completions-format'." + :type 'boolean + :version "28.1") + (defun completion--insert-strings (strings) "Insert a list of STRINGS into the current buffer. Uses columns to keep the listing readable but compact. @@ -1689,8 +1698,7 @@ completion--insert-strings (let* ((length (apply #'max (mapcar (lambda (s) (if (consp s) - (+ (string-width (car s)) - (string-width (cadr s))) + (apply #'+ (mapcar #'string-width s)) (string-width s))) strings))) (window (get-buffer-window (current-buffer) 0)) @@ -1715,10 +1723,14 @@ completion--insert-strings ;; FIXME: `string-width' doesn't pay attention to ;; `display' properties. (let ((length (if (consp str) - (+ (string-width (car str)) - (string-width (cadr str))) + (apply #'+ (mapcar #'string-width str)) (string-width str)))) (cond + ((and completions-detailed (= (length str) 3)) + ;; Detailed view + ;; When `str' contains prefix and suffix this means + ;; that caller specified `affix-function'. + ) ((eq completions-format 'vertical) ;; Vertical format (when (> row rows) @@ -1754,14 +1766,27 @@ completion--insert-strings (if (not (consp str)) (put-text-property (point) (progn (insert str) (point)) 'mouse-face 'highlight) - (put-text-property (point) (progn (insert (car str)) (point)) - 'mouse-face 'highlight) - (let ((beg (point)) - (end (progn (insert (cadr str)) (point)))) - (put-text-property beg end 'mouse-face nil) - (font-lock-prepend-text-property beg end 'face - 'completions-annotations))) + (let* ((prefix (when (nth 2 str) (nth 1 str))) + (suffix (or (nth 2 str) (nth 1 str)))) + (when prefix + (let ((beg (point)) + (end (progn (insert prefix) (point)))) + (put-text-property beg end 'mouse-face nil) + (font-lock-prepend-text-property beg end 'face + 'completions-annotations))) + (put-text-property (point) (progn (insert (car str)) (point)) + 'mouse-face 'highlight) + (let ((beg (point)) + (end (progn (insert suffix) (point)))) + (put-text-property beg end 'mouse-face nil) + (font-lock-prepend-text-property beg end 'face + 'completions-annotations)))) (cond + ((and completions-detailed (= (length str) 3)) + ;; Detailed view + (when (zerop row) (setq truncate-lines t)) + (insert "\n") + (setq row (1+ row))) ((eq completions-format 'vertical) ;; Vertical format (if (> column 0) @@ -1880,6 +1905,9 @@ completion-extra-properties completion). The function can access the completion data via `minibuffer-completion-table' and related variables. +`:affix-function': Function to prepend/append a prefix/suffix to completions. + The function must accept one argument, a list of completions. + `:exit-function': Function to run after completion is performed. The function must accept two arguments, STRING and STATUS. @@ -1966,6 +1994,9 @@ minibuffer-completion-help (plist-get completion-extra-properties :annotation-function) completion-annotate-function)) + (xfun (or (completion-metadata-get all-md 'affix-function) + (plist-get completion-extra-properties + :affix-function))) (mainbuf (current-buffer)) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in @@ -2012,6 +2043,9 @@ minibuffer-completion-help (let ((ann (funcall afun s))) (if ann (list s ann) s))) completions))) + (when xfun + (setq completions + (funcall xfun completions))) (with-current-buffer standard-output (set (make-local-variable 'completion-base-position)