master 3b74059: Add 'completions-detailed' to add prefix/suffix with 'affixation-function'

[Juri Linkov]

branch: master
commit 3b740591b0a1d0e7a24be38471499ecace96936b
Author: Juri Linkov <juri@linkov.net>
Commit: Juri Linkov <juri@linkov.net>

    Add 'completions-detailed' to add prefix/suffix with 'affixation-function'
    
    * doc/lispref/minibuf.texi (Completion Variables)
    (Programmed Completion): Add affixation-function.
    
    * lisp/help-fns.el (help--symbol-completion-table-affixation): New function.
    (help--symbol-completion-table): Set affixation-function when
    completions-detailed is non-nil.
    
    * lisp/minibuffer.el (completion-metadata): Add affixation-function
    to docstring.
    (completions-annotations): Inherit from shadow with italic.
    (completions-detailed): New defcustom.
    (completion--insert-strings): Count string-width on all strings in
    completion list.  Insert prefix and suffix.
    (completion-extra-properties): Add affixation-function to docstring.
    (minibuffer-completion-help): Call affixation-function.
    (minibuffer-default-prompt-format): Move down closer to its use.
    
    https://lists.gnu.org/archive/html/emacs-devel/2020-11/msg00613.html
---
 doc/lispref/minibuf.texi |  16 ++++++++
 etc/NEWS                 |  10 +++++
 lisp/help-fns.el         |  51 ++++++++++++++++++-----
 lisp/minibuffer.el       | 103 ++++++++++++++++++++++++++++++++---------------
 4 files changed, 138 insertions(+), 42 deletions(-)

diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index f1cfd29..56bc0b8 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -1798,6 +1798,13 @@ buffer.  This function must accept one argument, a 
completion, and
 should either return @code{nil} or a string to be displayed next to
 the completion.
 
+@item :affixation-function
+The value should be a function to add prefixes and suffixes to
+completions.  This function must accept one argument, a list of
+completions, and should return such a list of completions where
+each element contains a list of three elements: a completion,
+a prefix string, and a suffix string.
+
 @item :exit-function
 The value should be a function to run after performing completion.
 The function should accept two arguments, @var{string} and
@@ -1897,6 +1904,15 @@ function should take one argument, @var{string}, which 
is a possible
 completion.  It should return a string, which is displayed after the
 completion @var{string} in the @file{*Completions*} buffer.
 
+@item affixation-function
+The value should be a function for adding prefixes and suffixes to
+completions.  The function should take one argument,
+@var{completions}, which is a list of possible completions.  It should
+return such a list of @var{completions} where each element contains a list
+of three elements: a completion, a prefix which is displayed before
+the completion string in the @file{*Completions*} buffer, and
+a suffix displayed after the completion string.
+
 @item display-sort-function
 The value should be a function for sorting completions.  The function
 should take one argument, a list of completion strings, and return a
diff --git a/etc/NEWS b/etc/NEWS
index 0a3854d..9091643 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1341,6 +1341,10 @@ This new command (bound to 'C-c C-l') regenerates the 
current hunk.
 
 ** Miscellaneous
 
+*** New user option 'completions-detailed'.
+When non-nil, some commands like 'describe-symbol' show more detailed
+completions with more information in completion prefix and suffix.
+
 ---
 *** New user option 'bibtex-unify-case-convert'.
 This new option allows the user to customize how case is converted
@@ -1803,6 +1807,12 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el.
 * Lisp Changes in Emacs 28.1
 
 +++
+** New completion function 'affixation-function' to add prefix/suffix.
+It accepts a list of completions and should return a list where
+each element is a list with three elements: a completion,
+a prefix string, and a suffix string.
+
++++
 ** 'read-char-from-minibuffer' and 'y-or-n-p' support 'help-form'.
 If you bind 'help-form' to a non-nil value while calling these functions,
 then pressing 'C-h' (help-char) causes the function to evaluate 'help-form'
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 170f497..1c55d0e 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -126,17 +126,48 @@ with the current prefix.  The files are chosen according 
to
   :group 'help
   :version "26.3")
 
+(defun help--symbol-completion-table-affixation (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 (propertize
+                       (concat (cond ((commandp s)
+                                      "c") ; command
+                                     ((eq (car-safe (symbol-function s)) 
'macro)
+                                      "m") ; macro
+                                     ((fboundp s)
+                                      "f") ; function
+                                     ((custom-variable-p s)
+                                      "u") ; user option
+                                     ((boundp s)
+                                      "v") ; variable
+                                     ((facep s)
+                                      "a") ; fAce
+                                     ((and (fboundp 'cl-find-class)
+                                           (cl-find-class s))
+                                      "t")  ; CL type
+                                     (" ")) ; something else
+                               " ")         ; prefix separator
+                       'face 'completions-annotations)
+                    (if doc (propertize (format " -- %s" doc)
+                                        'face 'completions-annotations)
+                      ""))))
+          completions))
+
 (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 (and completions-detailed (eq action 'metadata))
+      '(metadata (affixation-function . 
help--symbol-completion-table-affixation))
+    (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 9d57a81..48bd395 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -83,7 +83,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 +120,10 @@ This metadata is an alist.  Currently understood keys are:
 - `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.
+- `affixation-function': function to prepend/append a prefix/suffix to
+   entries.  Takes one argument (COMPLETIONS) and should return a list
+   of completions with a list of three elements: 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 +1672,7 @@ Return nil if there is no valid completion, else t."
     (#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 +1684,13 @@ horizontally in alphabetical order, rather than down the 
screen."
   :type '(choice (const horizontal) (const vertical))
   :version "23.2")
 
+(defcustom completions-detailed nil
+  "When non-nil, display completions with details added as prefix/suffix.
+Some commands might provide a detailed view with more information prepended
+or appended to completions."
+  :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 +1699,7 @@ It also eliminates runs of equal 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,8 +1724,7 @@ It also eliminates runs of equal 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
             ((eq completions-format 'vertical)
@@ -1754,13 +1762,33 @@ It also eliminates runs of equal 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)))
+              ;; If `str' is a list that has 2 elements,
+              ;; then the second element is a suffix annotation.
+              ;; If `str' has 3 elements, then the second element
+              ;; is a prefix, and the third element is a suffix.
+              (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)
+                    ;; When both prefix and suffix are added
+                    ;; by the caller via affixation-function,
+                    ;; then allow the caller to decide
+                    ;; what faces to put on prefix and suffix.
+                    (unless prefix
+                      (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)
+                  ;; Put the predefined face only when suffix
+                  ;; is added via annotation-function.
+                  (unless prefix
+                    (font-lock-prepend-text-property
+                     beg end 'face 'completions-annotations)))))
            (cond
             ((eq completions-format 'vertical)
              ;; Vertical format
@@ -1880,6 +1908,11 @@ These include:
    completion).  The function can access the completion data via
    `minibuffer-completion-table' and related variables.
 
+`:affixation-function': Function to prepend/append a prefix/suffix to
+   completions.  The function must accept one argument, a list of
+   completions, and return a list where each element is a list of
+   three elements: a completion, a prefix and a suffix.
+
 `:exit-function': Function to run after completion is performed.
 
    The function must accept two arguments, STRING and STATUS.
@@ -1962,10 +1995,13 @@ variables.")
                                            base-size md
                                            minibuffer-completion-table
                                            minibuffer-completion-predicate))
-             (afun (or (completion-metadata-get all-md 'annotation-function)
-                       (plist-get completion-extra-properties
-                                  :annotation-function)
-                       completion-annotate-function))
+             (ann-fun (or (completion-metadata-get all-md 'annotation-function)
+                          (plist-get completion-extra-properties
+                                     :annotation-function)
+                          completion-annotate-function))
+             (aff-fun (or (completion-metadata-get all-md 'affixation-function)
+                          (plist-get completion-extra-properties
+                                     :affixation-function)))
              (mainbuf (current-buffer))
              ;; If the *Completions* buffer is shown in a new
              ;; window, mark it as softly-dedicated, so bury-buffer in
@@ -2006,12 +2042,15 @@ variables.")
                               (if sort-fun
                                   (funcall sort-fun completions)
                                 (sort completions 'string-lessp))))
-                      (when afun
+                      (when ann-fun
                         (setq completions
                               (mapcar (lambda (s)
-                                        (let ((ann (funcall afun s)))
+                                        (let ((ann (funcall ann-fun s)))
                                           (if ann (list s ann) s)))
                                       completions)))
+                      (when aff-fun
+                        (setq completions
+                              (funcall aff-fun completions)))
 
                       (with-current-buffer standard-output
                         (set (make-local-variable 'completion-base-position)
@@ -3034,19 +3073,6 @@ the commands start with a \"-\" or a SPC."
   :version "24.1"
   :type 'boolean)
 
-(defcustom minibuffer-default-prompt-format " (default %s)"
-  "Format string used to output \"default\" values.
-When prompting for input, there will often be a default value,
-leading to prompts like \"Number of articles (default 50): \".
-The \"default\" part of that prompt is controlled by this
-variable, and can be set to, for instance, \" [%s]\" if you want
-a shorter displayed prompt, or \"\", if you don't want to display
-the default at all.
-
-This variable is used by the `format-prompt' function."
-  :version "28.1"
-  :type 'string)
-
 (defun completion-pcm--pattern-trivial-p (pattern)
   (and (stringp (car pattern))
        ;; It can be followed by `point' and "" and still be trivial.
@@ -3864,6 +3890,19 @@ the minibuffer was activated, and execute the forms."
   (with-minibuffer-selected-window
     (scroll-other-window-down arg)))
 
+(defcustom minibuffer-default-prompt-format " (default %s)"
+  "Format string used to output \"default\" values.
+When prompting for input, there will often be a default value,
+leading to prompts like \"Number of articles (default 50): \".
+The \"default\" part of that prompt is controlled by this
+variable, and can be set to, for instance, \" [%s]\" if you want
+a shorter displayed prompt, or \"\", if you don't want to display
+the default at all.
+
+This variable is used by the `format-prompt' function."
+  :version "28.1"
+  :type 'string)
+
 (defun format-prompt (prompt default &rest format-args)
   "Format PROMPT with DEFAULT according to `minibuffer-default-prompt-format'.
 If FORMAT-ARGS is nil, PROMPT is used as a plain string.  If