unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
* [PATCH] `completing-read`: Add `group-function` support to completion metadata
@ 2021-04-25 13:32 Daniel Mendler
  2021-04-25 19:35 ` Dmitry Gutov
  2021-04-25 19:38 ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH) Daniel Mendler
  0 siblings, 2 replies; 81+ messages in thread
From: Daniel Mendler @ 2021-04-25 13:32 UTC (permalink / raw)
  To: emacs-devel@gnu.org; +Cc: Gregory Heytings, Stefan Monnier, Dmitry Gutov

[-- Attachment #1: Type: text/plain, Size: 930 bytes --]

I attached a patch which adds grouping support to the completions 
buffer. The completion table can specify a `group-function` via its 
completion metadata.

Currently groups are only displayed in the *Completions* buffer if 
`completions-format=one-column`. My proposal is to split up the function 
`completion--insert-strings` into three functions 
`completion--insert-strings-one-column/vertical/horizontal` in a 
follow-up patch. Then the grouping display can also be implemented for 
the other display formats.

Group title support is already present in the Vertico, Selectrum and 
external Icomplete-vertical UI. Similarly we can add support to the 
recently added `icomplete-vertical-mode` by Gregory.

There is a patch to `xref.el` included, which makes use of the grouping 
functionality, when the `completing-read` show function is used:

(setq xref-show-xrefs-function #'xref-show-definitions-completing-read)

Daniel


[-- Attachment #2: 0001-completing-read-Add-group-function-to-completion-met.patch --]
[-- Type: text/x-diff, Size: 17730 bytes --]

From f79806a7b41f55b1e78e6e708d6f3045bfb428e2 Mon Sep 17 00:00:00 2001
From: Daniel Mendler <mail@daniel-mendler.de>
Date: Sun, 25 Apr 2021 13:07:29 +0200
Subject: [PATCH] (completing-read): Add `group-function` to completion
 metadata

A completion table can specify a `group-function` in its metadata.
The group function takes two arguments, a completion string and a
transform argument. The group function is used to group the candidates
after sorting.

If the transform argument is nil, the function should return the group
title of the group to which the completion belongs. Otherwise the
function should return the transformed candidate. The transformation
allows to remove parts of the candidate, which is then displayed in
the title.

This specific form of the `group-function` has been chosen in order to
allow allocation-free grouping. This is important for completion UIs,
which continously update the displayed set of candidates (Icomplete,
Vertico, Ivy, etc.). Only when the transform argument is non-nil the
candidate transformation is performed, which may involve a string
allocation as for example in `xref--completing-read-group`.

The function `xref-show-definitions-completing-read` makes use of the
`group-function`, by moving the file name prefix to the title. If
group titles are activated the *Completions* are displayed as "line
number:matching line" instead of "file name:line number:matching
line". This way the *Completions* buffer resembles the *Occur* buffer.

* doc/lispref/minibuf.texi: Add documentation.

* lisp/minibuffer.el: Add documentation for `group-function` as part
of completion metadata.
(completions-group-format): Add format string for group titles. The
format string can be nil in order to disable the titles.
(completions-group-title): Add face for group titles.
(completions-group-separator): Add face for group separator.
(minibuffer--group-by): New grouping function.
(completion-all-sorted-completions): Use it.
(minibuffer-completion-help): Use it.
(display-completion-list): Add optional GROUP-FUN argument.
(completion--insert-strings): Add optional GROUP-FUN argument, insert
group titles if `completions-format` is `one-column`.

* lisp/progmodes/xref.el:
(xref--completing-read-group): New grouping function.
(xref-show-definitions-completing-read): Use it.
---
 doc/lispref/minibuf.texi |  10 ++++
 lisp/minibuffer.el       | 117 ++++++++++++++++++++++++++++++++-------
 lisp/progmodes/xref.el   |  18 ++++--
 3 files changed, 121 insertions(+), 24 deletions(-)

diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index 7cf2fcf68f..a934a90862 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -1947,6 +1947,16 @@ Programmed Completion
 a completion and a suffix string like in @code{annotation-function}.
 This function takes priority over @code{annotation-function}.
 
+@item group-function
+The value should be a function for grouping the completion candidates.
+The function should take two arguments, @var{completion}, which is a
+completion candidate and @var{transform}, which is a boolean flag.  If
+@var{transform} is @code{nil}, the function should return a group
+title, to which the candidate belongs. Otherwise the function should
+return the transformed candidate. The transformation can for example
+remove a redundant prefix, which is displayed in the group title
+instead.
+
 @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/lisp/minibuffer.el b/lisp/minibuffer.el
index 98691c2ede..dd59e6cfd6 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -126,6 +126,13 @@ completion-metadata
    and suffix, or three elements: completion, its prefix
    and suffix.  This function takes priority over `annotation-function'
    when both are provided, so only this function is used.
+- `group-function': function for grouping the completion candidates.
+   Takes two arguments: a completion candidate (COMPLETION) and a
+   boolean flag (TRANSFORM).  If TRANSFORM is nil, the function
+   returns a group title, to which the candidate belongs.  Otherwise
+   the function returns the transformed candidate.  The transformation
+   can remove a redundant prefix, which is displayed in the group
+   title instead.
 - `display-sort-function': function to sort entries in *Completions*.
    Takes one argument (COMPLETIONS) and should return a new list
    of completions.  Can operate destructively.
@@ -1401,6 +1408,17 @@ minibuffer--sort-preprocess-history
                      (substring c base-size)))
                  hist)))))
 
+(defun minibuffer--group-by (fun elems)
+  "Group ELEMS by FUN."
+  (let ((groups))
+    (dolist (cand elems)
+      (let* ((key (funcall fun cand nil))
+             (group (assoc key groups)))
+        (if group
+            (setcdr group (cons cand (cdr group)))
+          (push (list key cand) groups))))
+    (mapcan (lambda (x) (nreverse (cdr x))) (nreverse groups))))
+
 (defun completion-all-sorted-completions (&optional start end)
   (or completion-all-sorted-completions
       (let* ((start (or start (minibuffer-prompt-end)))
@@ -1420,7 +1438,8 @@ completion-all-sorted-completions
                                            base-size md
                                            minibuffer-completion-table
                                            minibuffer-completion-predicate))
-             (sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
+             (sort-fun (completion-metadata-get all-md 'cycle-sort-function))
+             (group-fun (completion-metadata-get all-md 'group-function)))
         (when last
           (setcdr last nil)
 
@@ -1442,6 +1461,13 @@ completion-all-sorted-completions
                           (substring string 0 base-size))
                          all))))
 
+          ;; Group candidates using the group function after sorting.
+          ;; While the candidates are separated in groups, the sorting
+          ;; order is preserved within the groups. The first
+          ;; completion determines which group is presented first.
+          (when group-fun
+            (setq all (minibuffer--group-by group-fun all)))
+
           ;; Cache the result.  This is not just for speed, but also so that
           ;; repeated calls to minibuffer-force-complete can cycle through
           ;; all possibilities.
@@ -1729,6 +1755,22 @@ completion-in-region--single-word
 (defface completions-annotations '((t :inherit (italic shadow)))
   "Face to use for annotations in the *Completions* buffer.")
 
+(defcustom completions-group-format
+  (concat
+   (propertize "    " 'face 'completions-group-separator)
+   (propertize " %s " 'face 'completions-group-title)
+   (propertize " " 'face 'completions-group-separator
+               'display '(space :align-to right)))
+  "Format string used for the group title."
+  :type '(choice (const :tag "No group titles" nil)
+                 string))
+
+(defface completions-group-title '((t :inherit shadow :slant italic))
+  "Face used for the title text of the candidate group headlines.")
+
+(defface completions-group-separator '((t :inherit shadow :strike-through t))
+  "Face used for the separator lines of the candidate groups.")
+
 (defcustom completions-format 'horizontal
   "Define the appearance and sorting of completions.
 If the value is `vertical', display completions sorted vertically
@@ -1747,11 +1789,17 @@ completions-detailed
   :type 'boolean
   :version "28.1")
 
-(defun completion--insert-strings (strings)
+;; TODO: Split up this function in one function per `completions-format'.
+;; TODO: Add group title support for horizontal and vertical format.
+(defun completion--insert-strings (strings &optional group-fun)
   "Insert a list of STRINGS into the current buffer.
-Uses columns to keep the listing readable but compact.
-It also eliminates runs of equal strings."
+Uses columns to keep the listing readable but compact.  It also
+eliminates runs of equal strings.  GROUP-FUN is a `group-function'
+used for grouping the completion."
   (when (consp strings)
+    ;; Enable grouping only for 'one-column-format
+    (unless (and (eq completions-format 'one-column) completions-group-format)
+      (setq group-fun nil))
     (let* ((length (apply #'max
 			  (mapcar (lambda (s)
 				    (if (consp s)
@@ -1768,6 +1816,7 @@ completion--insert-strings
 		     (max 1 (/ (length strings) 2))))
 	   (colwidth (/ wwidth columns))
            (column 0)
+           (last-title nil)
 	   (rows (/ (length strings) columns))
 	   (row 0)
            (first t)
@@ -1780,6 +1829,12 @@ completion--insert-strings
       ;; The insertion should be "sensible" no matter what choices were made
       ;; for the parameters above.
       (dolist (str strings)
+        ;; Add group titles.
+        (when group-fun
+          (let ((title (funcall group-fun (if (consp str) (car str) str) nil)))
+            (unless (equal title last-title)
+              (insert (format completions-group-format title))
+              (setq last-title title))))
 	(unless (equal laststring str) ; Remove (consecutive) duplicates.
 	  (setq laststring str)
           ;; FIXME: `string-width' doesn't pay attention to
@@ -1825,7 +1880,13 @@ completion--insert-strings
 		  nil))))
             (setq first nil)
             (if (not (consp str))
-                (put-text-property (point) (progn (insert str) (point))
+                (put-text-property (point)
+                                   (progn
+                                     (insert
+                                      (if group-fun
+                                          (funcall group-fun str 'transform)
+                                        str))
+                                     (point))
                                    'mouse-face 'highlight)
               ;; If `str' is a list that has 2 elements,
               ;; then the second element is a suffix annotation.
@@ -1837,7 +1898,13 @@ completion--insert-strings
                   (let ((beg (point))
                         (end (progn (insert prefix) (point))))
                     (put-text-property beg end 'mouse-face nil)))
-                (put-text-property (point) (progn (insert (car str)) (point))
+                (put-text-property (point)
+                                   (progn
+                                     (insert
+                                      (if group-fun
+                                          (funcall group-fun (car str) 'transform)
+                                        (car str)))
+                                     (point))
                                    'mouse-face 'highlight)
                 (let ((beg (point))
                       (end (progn (insert suffix) (point))))
@@ -1923,7 +1990,7 @@ completion-hilit-commonality
         completions)
        base-size))))
 
-(defun display-completion-list (completions &optional common-substring)
+(defun display-completion-list (completions &optional common-substring group-fun)
   "Display the list of completions, COMPLETIONS, using `standard-output'.
 Each element may be just a symbol or string
 or may be a list of two strings to be printed as if concatenated.
@@ -1933,7 +2000,8 @@ display-completion-list
 The actual completion alternatives, as inserted, are given `mouse-face'
 properties of `highlight'.
 At the end, this runs the normal hook `completion-setup-hook'.
-It can find the completion buffer in `standard-output'."
+It can find the completion buffer in `standard-output'.
+GROUP-FUN is a `group-function' used for grouping the completion."
   (declare (advertised-calling-convention (completions) "24.4"))
   (if common-substring
       (setq completions (completion-hilit-commonality
@@ -1946,7 +2014,7 @@ display-completion-list
 	(let ((standard-output (current-buffer))
 	      (completion-setup-hook nil))
           (with-suppressed-warnings ((callargs display-completion-list))
-	    (display-completion-list completions common-substring)))
+	    (display-completion-list completions common-substring group-fun)))
 	(princ (buffer-string)))
 
     (with-current-buffer standard-output
@@ -1954,7 +2022,7 @@ display-completion-list
       (if (null completions)
           (insert "There are no possible completions of what you have typed.")
         (insert "Possible completions are:\n")
-        (completion--insert-strings completions))))
+        (completion--insert-strings completions group-fun))))
 
   (run-hooks 'completion-setup-hook)
   nil)
@@ -2067,6 +2135,8 @@ minibuffer-completion-help
              (aff-fun (or (completion-metadata-get all-md 'affixation-function)
                           (plist-get completion-extra-properties
                                      :affixation-function)))
+             (sort-fun (completion-metadata-get all-md 'display-sort-function))
+             (group-fun (completion-metadata-get all-md 'group-function))
              (mainbuf (current-buffer))
              ;; If the *Completions* buffer is shown in a new
              ;; window, mark it as softly-dedicated, so bury-buffer in
@@ -2098,15 +2168,22 @@ minibuffer-completion-help
                       ;; Remove the base-size tail because `sort' requires a properly
                       ;; nil-terminated list.
                       (when last (setcdr last nil))
-                      (setq completions
-                            ;; FIXME: This function is for the output of all-completions,
-                            ;; not completion-all-completions.  Often it's the same, but
-                            ;; not always.
-                            (let ((sort-fun (completion-metadata-get
-                                             all-md 'display-sort-function)))
-                              (if sort-fun
-                                  (funcall sort-fun completions)
-                                (sort completions 'string-lessp))))
+
+                      ;; Sort first using the `display-sort-function'.
+                      ;; FIXME: This function is for the output of
+                      ;; all-completions, not
+                      ;; completion-all-completions.  Often it's the
+                      ;; same, but not always.
+                      (setq completions (if sort-fun
+                                            (funcall sort-fun completions)
+                                          (sort completions 'string-lessp)))
+
+                      ;; After sorting, group the candidates using the
+                      ;; `group-function'.
+                      (when group-fun
+                        (setq completions
+                              (minibuffer--group-by group-fun completions)))
+
                       (cond
                        (aff-fun
                         (setq completions
@@ -2152,7 +2229,7 @@ minibuffer-completion-help
                                                      (if (eq (car bounds) (length result))
                                                          'exact 'finished)))))))
 
-                      (display-completion-list completions)))))
+                      (display-completion-list completions nil group-fun)))))
           nil)))
     nil))
 
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index e80603f23e..40faf99f20 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1044,6 +1044,12 @@ xref-show-definitions-buffer-at-bottom
 (define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom
   #'xref-show-definitions-buffer-at-bottom "28.1")
 
+(defun xref--completing-read-group (cand transform)
+  "Return title of candidate CAND or TRANSFORM the candidate."
+  (if transform
+      (substring cand (1+ (next-single-property-change 0 'xref--group cand)))
+    (get-text-property 0 'xref--group cand)))
+
 (defun xref-show-definitions-completing-read (fetcher alist)
   "Let the user choose the target definition with completion.
 
@@ -1072,10 +1078,12 @@ xref-show-definitions-completing-read
                                     (format #("%d:" 0 2 (face xref-line-number))
                                             line)
                                   ""))
+                               (group-prefix
+                                (substring group group-prefix-length))
                                (group-fmt
-                                (propertize
-                                 (substring group group-prefix-length)
-                                 'face 'xref-file-header))
+                                (propertize group-prefix
+                                            'face 'xref-file-header
+                                            'xref--group group-prefix))
                                (candidate
                                 (format "%s:%s%s" group-fmt line-fmt summary)))
                           (push (cons candidate xref) xref-alist-with-line-info)))))
@@ -1087,7 +1095,9 @@ xref-show-definitions-completing-read
                          (lambda (string pred action)
                            (cond
                             ((eq action 'metadata)
-                             '(metadata . ((category . xref-location))))
+                             `(metadata
+                               . ((category . xref-location)
+                                  (group-function . ,#'xref--completing-read-group))))
                             (t
                              (complete-with-action action collection string pred)))))
                         (def (caar collection)))
-- 
2.20.1


^ permalink raw reply related	[flat|nested] 81+ messages in thread
end of thread, other threads:[~2021-05-20 18:51 UTC | newest]

Thread overview: 81+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2021-04-25 13:32 [PATCH] `completing-read`: Add `group-function` support to completion metadata Daniel Mendler
2021-04-25 19:35 ` Dmitry Gutov
2021-04-25 19:47   ` Daniel Mendler
2021-04-25 21:50     ` Dmitry Gutov
2021-04-25 22:10       ` Daniel Mendler
2021-04-25 22:40         ` Dmitry Gutov
2021-04-25 22:58           ` Daniel Mendler
2021-04-26  4:51             ` Protesilaos Stavrou
2021-04-27 16:53               ` Juri Linkov
2021-04-28  6:18                 ` Protesilaos Stavrou
2021-04-25 23:33           ` Stefan Monnier
2021-04-26 10:01             ` Daniel Mendler
2021-04-26 13:50               ` Stefan Monnier
2021-04-27  1:46             ` Dmitry Gutov
2021-04-27  1:59               ` tumashu
2021-04-27  2:45                 ` Daniel Mendler
2021-04-27 15:47                 ` Dmitry Gutov
2021-04-27  3:41               ` Stefan Monnier
2021-04-28  0:08                 ` Dmitry Gutov
2021-04-28  3:21                   ` Stefan Monnier
2021-04-25 19:38 ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH) Daniel Mendler
2021-04-25 20:45   ` Juri Linkov
2021-04-25 21:26     ` Daniel Mendler
2021-04-29 16:20   ` Juri Linkov
2021-04-29 16:52     ` Daniel Mendler
2021-04-29 17:07     ` Stefan Monnier
2021-04-29 17:13       ` Daniel Mendler
2021-04-29 22:54         ` Juri Linkov
2021-04-29 23:55           ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 2) Daniel Mendler
2021-04-30  9:00             ` Daniel Mendler
2021-04-30 17:01               ` Juri Linkov
2021-04-30 18:11                 ` Daniel Mendler
2021-04-30 18:30                   ` Daniel Mendler
2021-05-01 19:57                     ` Juri Linkov
2021-05-02  0:43                       ` Daniel Mendler
2021-05-02  7:07                         ` Eli Zaretskii
2021-05-02 11:01                           ` Daniel Mendler
2021-04-30 16:51             ` Juri Linkov
2021-04-30 18:13               ` Daniel Mendler
2021-05-01 19:54                 ` Juri Linkov
2021-05-02  0:32                   ` Daniel Mendler
2021-05-02 21:38                     ` Juri Linkov
2021-05-07 17:03                       ` Juri Linkov
2021-05-07 17:55                         ` Daniel Mendler
2021-05-08  6:24                           ` Daniel Mendler
2021-05-08  8:45                             ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 4) Daniel Mendler
2021-05-08  9:10                               ` Daniel Mendler
2021-05-09 17:59                                 ` Juri Linkov
2021-05-09 18:50                                   ` Daniel Mendler
2021-05-09 18:56                                     ` Stefan Monnier
2021-05-09 19:11                                       ` Daniel Mendler
2021-05-10 20:47                                     ` Juri Linkov
2021-05-11  7:51                                       ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 5) Daniel Mendler
2021-05-11 17:59                                         ` Juri Linkov
2021-05-08 13:15                         ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 2) Stefan Monnier
2021-05-09 18:05                           ` Juri Linkov
2021-05-09 18:37                             ` Eli Zaretskii
2021-05-11 18:06                               ` Juri Linkov
2021-05-11 18:44                                 ` Eli Zaretskii
2021-05-11 18:58                                   ` Daniel Mendler
2021-05-11 19:22                                     ` Eli Zaretskii
2021-05-11 19:46                                       ` Daniel Mendler
2021-05-11 19:59                                         ` Eli Zaretskii
2021-05-11 20:30                                           ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 6) Daniel Mendler
2021-05-13 10:32                                             ` Eli Zaretskii
2021-05-13 11:45                                               ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 7) Daniel Mendler
2021-05-20  9:39                                                 ` Daniel Mendler
2021-05-20 17:53                                                   ` Juri Linkov
2021-05-20 18:51                                                     ` Daniel Mendler
2021-04-29 17:09     ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH) Dmitry Gutov
2021-04-29 17:16       ` Daniel Mendler
2021-04-29 17:55         ` Dmitry Gutov
2021-04-29 18:31           ` [External] : " Drew Adams
2021-04-29 20:25             ` Dmitry Gutov
2021-04-29 22:15               ` Drew Adams
2021-04-29 22:28                 ` Dmitry Gutov
2021-04-29 23:31                   ` Drew Adams
2021-04-29 19:21           ` Daniel Mendler
2021-05-02 14:29   ` [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 3) Daniel Mendler
2021-05-02 21:49     ` Juri Linkov
2021-05-03 14:40       ` Daniel Mendler

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).