From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Daniel Mendler Newsgroups: gmane.emacs.devel Subject: Re: [PATCH] `completing-read`: Add `group-function` support to completion metadata (REVISED PATCH VERSION 4) Date: Sat, 8 May 2021 10:45:24 +0200 Message-ID: <069cec7d-db2c-8628-69fb-a2aee4ee5074@daniel-mendler.de> References: <0bbdeece-90d5-160c-07ec-2ad8edbf9872@daniel-mendler.de> <87czudm7bv.fsf@mail.linkov.net> <976056e8-3d46-db27-32c2-ddf3ca32d5a7@daniel-mendler.de> <878s5090e9.fsf@mail.linkov.net> <69fd42ed-a1a0-adcb-ac8b-caad80cb0967@daniel-mendler.de> <878s4zzpvc.fsf@mail.linkov.net> <95ac7ef3-5e8c-fc58-b316-544096c82aa0@daniel-mendler.de> <87o8dus00b.fsf@mail.linkov.net> <6718c89f-88a0-b529-1676-7e89fc152f00@daniel-mendler.de> <878s4w3law.fsf@mail.linkov.net> <87sg2ymq6j.fsf@mail.linkov.net> <78bb0663-80ef-a68f-c582-cd7cc0436c29@daniel-mendler.de> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------BFABFB5E9145C030B154ECB5" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="28045"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Gregory Heytings , Dmitry Gutov , Stefan Monnier , "emacs-devel@gnu.org" To: Juri Linkov Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Sat May 08 10:46:50 2021 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1lfIbq-00078s-Bp for ged-emacs-devel@m.gmane-mx.org; Sat, 08 May 2021 10:46:50 +0200 Original-Received: from localhost ([::1]:45944 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lfIbp-0007IO-96 for ged-emacs-devel@m.gmane-mx.org; Sat, 08 May 2021 04:46:49 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:43464) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lfIad-0006Vs-VZ for emacs-devel@gnu.org; Sat, 08 May 2021 04:45:36 -0400 Original-Received: from server.qxqx.de ([2a01:4f8:121:346::180]:57435 helo=mail.qxqx.de) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lfIaY-0000pL-I7 for emacs-devel@gnu.org; Sat, 08 May 2021 04:45:35 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=qxqx.de; s=mail1392553390; h=Content-Type:In-Reply-To:MIME-Version:Date:Message-ID: References:Cc:To:From:Subject:Sender:Reply-To:Content-Transfer-Encoding: Content-ID:Content-Description:Resent-Date:Resent-From:Resent-Sender: Resent-To:Resent-Cc:Resent-Message-ID:List-Id:List-Help:List-Unsubscribe: List-Subscribe:List-Post:List-Owner:List-Archive; bh=82UybXMfWV0IL7bHJOwlYu52OWZlcKIo1gik61M0D+Y=; b=J3/i+UEMVQ/YiqSCcjMVwnOEt5 RBr0zwdNCfMTjn9GVyBAei0M98A7C8AXlu3LZ6l6F55xQix0SDgIc01IAv9P814pDCLwtcjtL7oPb /iycANhlvpBlw4WnNLRazzySCvJcjhuxjyihWlXu2IEtQgTqv2OXEUyRQXfpJFgXqAbo=; In-Reply-To: Content-Language: en-US Received-SPF: pass client-ip=2a01:4f8:121:346::180; envelope-from=mail@daniel-mendler.de; helo=mail.qxqx.de X-Spam_score_int: -41 X-Spam_score: -4.2 X-Spam_bar: ---- X-Spam_report: (-4.2 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, RCVD_IN_DNSWL_MED=-2.3, SPF_HELO_PASS=-0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.23 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:269030 Archived-At: This is a multi-part message in MIME format. --------------BFABFB5E9145C030B154ECB5 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 7bit On 5/8/21 8:24 AM, Daniel Mendler wrote: > On 5/7/21 7:55 PM, Daniel Mendler wrote: >> On 5/7/21 7:03 PM, Juri Linkov wrote: >>> I tried to remove `read-char-by-name-group`, but it has a feature >>> currently not supported by `group-function`: >>> >>> (defcustom read-char-by-name-group nil >>> "How to group characters for `read-char-by-name' completion. >>> When t, split characters to sections of Unicode blocks >>> sorted alphabetically." >>> ===================== >>> >>> It seems a new function is needed to sort groups, e.g. `group-sort-function`. > > 3. Use a single function with an action argument > 3.1 group-function : (action=title) -> string -> string > 3.2 group-function : (action=transform) -> string -> string > 3.3 group-function : (action=sort) -> list string -> list string I attached the current set of patches. The last patch "0005-group-function-Implement-generalized-action-argument.patch" implements the generalized action argument. The other patches (1-4) do not differ from the previously sent patches. I send them for completeness. Given the lastest patch, the `group-function` works as follows: (group-function 'title cand) --> returns group title (group-function 'transform cand) --> returns transformed candidate (group-function 'sort groups) --> returns sorted alist of groups The modification is quite minimal over the previous version with the boolean transform argument. For completion tables which only want to provide group titles, the group function definition is equally simple as before: (defun some-group-function (action arg) (if (eq action 'title) (get-title arg) arg)) Daniel --------------BFABFB5E9145C030B154ECB5 Content-Type: text/x-diff; charset=UTF-8; name="0001-completing-read-Add-group-function-to-completion-met.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename*0="0001-completing-read-Add-group-function-to-completion-met.pa"; filename*1="tch" >From 0f3ca048761cfee5717858dcceba03ca6709c37f Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Sun, 25 Apr 2021 13:07:29 +0200 Subject: [PATCH 1/5] (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 candidate and a transform argument. The group function is used to group the candidates after sorting and to enhance the completion UI with group titles. If the transform argument is nil, the function must return the title of the group to which the completion candidate belongs. The function may also return nil in case the candidate does not belong to a group. Otherwise the function must return the transformed candidate. The transformation allows for example to remove a part of the candidate, which is then displayed in the title. The grouping functionality guarded by the variable `completions-group` and turned off by default for the *Completions* buffer. The 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 grouping is enabled, the *Completions* are displayed as "linenum:summary" instead of "file:linenum:summary". This way the *Completions* buffer resembles the *Occur* buffer. * doc/lispref/minibuf.texi: Add documentation. * lisp/minibuffer.el (completion-metadata): Describe `group-function` in the docstring. (completions-group): Add guard variable, by default off. (completions-group-format): Add format string for group titles. (completions-group-title): Add face for group titles. (completions-group-separator): Add face for group separator. (minibuffer--group-by): New grouping function. (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`. Transform each candidate with the GROUP-FUN. Attach the untransformed candidate to the property `completion--string`. * lisp/simple.el (choose-completion): Retrieve the untransformed completion candidate from the property `completion--string`. * 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 | 123 ++++++++++++++++++++++++++++++++------- lisp/progmodes/xref.el | 18 ++++-- lisp/simple.el | 11 ++-- 4 files changed, 131 insertions(+), 31 deletions(-) diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index 145eee8f06..aa57c2bda0 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -1943,6 +1943,16 @@ Programmed Completion a suffix displayed after the completion string. This function takes priority over @code{annotation-function}. +@item group-function +The value should be a function for grouping the completion candidates. +The function must 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 must return a group title, +to which the candidate belongs. The returned title can also +@code{nil}. Otherwise the function must 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 caf06ec710..e21a699dae 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -126,6 +126,13 @@ completion-metadata three-element lists: 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. The + returned title may be nil. 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. @@ -1138,6 +1145,30 @@ completion-cycle-threshold :version "24.1" :type completion--cycling-threshold-type) +(defcustom completions-group nil + "Enable grouping of completion candidates in the *Completions* buffer. +See also `completions-group-format'." + :type 'boolean + :version "28.1") + +(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 'string + :version "28.1") + +(defface completions-group-title '((t :inherit shadow :slant italic)) + "Face used for the title text of the candidate group headlines." + :version "28.1") + +(defface completions-group-separator '((t :inherit shadow :strike-through t)) + "Face used for the separator lines of the candidate groups." + :version "28.1") + (defun completion--cycle-threshold (metadata) (let* ((cat (completion-metadata-get metadata 'category)) (over (completion--category-override cat 'cycle))) @@ -1401,6 +1432,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))) @@ -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) + ;; FIXME: Currently grouping is enabled only for the 'one-column format. + (unless (eq completions-format 'one-column) + (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,13 @@ 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) + (when title + (insert (format completions-group-format title) "\n")) + (setq last-title title)))) (unless (equal laststring str) ; Remove (consecutive) duplicates. (setq laststring str) ;; FIXME: `string-width' doesn't pay attention to @@ -1825,8 +1881,15 @@ completion--insert-strings nil)))) (setq first nil) (if (not (consp str)) - (put-text-property (point) (progn (insert str) (point)) - 'mouse-face 'highlight) + (add-text-properties + (point) + (progn + (insert + (if group-fun + (funcall group-fun str 'transform) + str)) + (point)) + `(mouse-face highlight completion--string ,str)) ;; 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 @@ -1837,8 +1900,15 @@ 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)) - 'mouse-face 'highlight) + (add-text-properties + (point) + (progn + (insert + (if group-fun + (funcall group-fun (car str) 'transform) + (car str))) + (point)) + `(mouse-face highlight completion--string ,(car str))) (let ((beg (point)) (end (progn (insert suffix) (point)))) (put-text-property beg end 'mouse-face nil) @@ -1923,7 +1993,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 +2003,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 +2017,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 +2025,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 +2138,9 @@ 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 (and completions-group + (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 +2172,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 +2233,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 7fc7181acc..2a4fb2c417 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 group 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))) diff --git a/lisp/simple.el b/lisp/simple.el index b4e34f1e4c..fe7ff0333f 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -8876,18 +8876,17 @@ choose-completion (choice (save-excursion (goto-char (posn-point (event-start event))) - (let (beg end) + (let (beg) (cond ((and (not (eobp)) (get-text-property (point) 'mouse-face)) - (setq end (point) beg (1+ (point)))) + (setq beg (1+ (point)))) ((and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) - (setq end (1- (point)) beg (point))) + (setq beg (point))) (t (error "No completion here"))) (setq beg (previous-single-property-change beg 'mouse-face)) - (setq end (or (next-single-property-change end 'mouse-face) - (point-max))) - (buffer-substring-no-properties beg end))))) + (substring-no-properties + (get-text-property beg 'completion--string)))))) (unless (buffer-live-p buffer) (error "Destination buffer is dead")) -- 2.20.1 --------------BFABFB5E9145C030B154ECB5 Content-Type: text/x-diff; charset=UTF-8; name="0002-completion-insert-strings-Split-function-Full-group-.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename*0="0002-completion-insert-strings-Split-function-Full-group-.pa"; filename*1="tch" >From fa81e97590384cb97e24ef5a9a91301d030f2736 Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Fri, 30 Apr 2021 08:40:59 +0200 Subject: [PATCH 2/5] (completion--insert-strings): Split function; Full group title support Split `completion--insert-strings` into a function per completions format in order to increase readability and extensibility. This change eases the addition of more formats. Add support for group titles to the vertical and horizontal format. * minibuffer.el (completion--insert): Add new function. (completion--insert-vertical, completion--insert-horizontal, completion--insert-one-column): Extract new function from `completion--insert-strings`. Use `completion--insert`. (completion--insert-strings): Use new insertion functions. --- lisp/minibuffer.el | 269 ++++++++++++++++++++++++++------------------- 1 file changed, 154 insertions(+), 115 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index e21a699dae..cf1a4350bd 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1789,21 +1789,16 @@ completions-detailed :type 'boolean :version "28.1") -;; 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. GROUP-FUN is a `group-function' used for grouping the completion." (when (consp strings) - ;; FIXME: Currently grouping is enabled only for the 'one-column format. - (unless (eq completions-format 'one-column) - (setq group-fun nil)) (let* ((length (apply #'max (mapcar (lambda (s) (if (consp s) - (apply #'+ (mapcar #'string-width s)) + (apply #'+ (mapcar #'string-width s)) (string-width s))) strings))) (window (get-buffer-window (current-buffer) 0)) @@ -1814,126 +1809,170 @@ completion--insert-strings ;; Don't allocate more columns than we can fill. ;; Windows can't show less than 3 lines anyway. (max 1 (/ (length strings) 2)))) - (colwidth (/ wwidth columns)) - (column 0) - (last-title nil) - (rows (/ (length strings) columns)) - (row 0) - (first t) - (laststring nil)) + (colwidth (/ wwidth columns))) (unless (or tab-stop-list (null completion-tab-width) (zerop (mod colwidth completion-tab-width))) ;; Align to tab positions for the case ;; when the caller uses tabs inside prefix. (setq colwidth (- colwidth (mod colwidth completion-tab-width)))) - ;; The insertion should be "sensible" no matter what choices were made - ;; for the parameters above. - (dolist (str strings) - ;; Add group titles. + (funcall (intern (format "completion--insert-%s" completions-format)) + strings group-fun length wwidth colwidth columns)))) + +(defun completion--insert-horizontal (strings group-fun + length wwidth + colwidth _columns) + (let ((column 0) + (first t) + (last-title nil) + (last-string nil)) + (dolist (str strings) + (unless (equal last-string str) ; Remove (consecutive) duplicates. + (setq last-string str) (when group-fun (let ((title (funcall group-fun (if (consp str) (car str) str) nil))) (unless (equal title last-title) + (setq last-title title) (when title - (insert (format completions-group-format title) "\n")) - (setq last-title title)))) - (unless (equal laststring str) ; Remove (consecutive) duplicates. - (setq laststring str) + (insert (if first "" "\n") (format completions-group-format title) "\n") + (setq column 0 + first t))))) + (unless first ;; FIXME: `string-width' doesn't pay attention to ;; `display' properties. - (let ((length (if (consp str) - (apply #'+ (mapcar #'string-width str)) - (string-width str)))) - (cond - ((eq completions-format 'one-column) - ;; Nothing special - ) - ((eq completions-format 'vertical) - ;; Vertical format - (when (> row rows) - (forward-line (- -1 rows)) - (setq row 0 column (+ column colwidth))) - (when (> column 0) - (end-of-line) - (while (> (current-column) column) - (if (eobp) - (insert "\n") - (forward-line 1) - (end-of-line))) - (insert " \t") - (set-text-properties (1- (point)) (point) - `(display (space :align-to ,column))))) - (t - ;; Horizontal format - (unless first - (if (< wwidth (+ (max colwidth length) column)) - ;; No space for `str' at point, move to next line. - (progn (insert "\n") (setq column 0)) - (insert " \t") - ;; Leave the space unpropertized so that in the case we're - ;; already past the goal column, there is still - ;; a space displayed. - (set-text-properties (1- (point)) (point) - ;; We can set tab-width using - ;; completion-tab-width, but - ;; the caller can prefer using - ;; \t to align prefixes. - `(display (space :align-to ,column))) - nil)))) - (setq first nil) - (if (not (consp str)) - (add-text-properties - (point) - (progn - (insert - (if group-fun - (funcall group-fun str 'transform) - str)) - (point)) - `(mouse-face highlight completion--string ,str)) - ;; 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))) - (add-text-properties - (point) - (progn - (insert - (if group-fun - (funcall group-fun (car str) 'transform) - (car str))) - (point)) - `(mouse-face highlight completion--string ,(car str))) - (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 without prefix, - ;; and when the caller doesn't use own face. - (unless (or prefix (text-property-not-all - 0 (length suffix) 'face nil suffix)) - (font-lock-prepend-text-property - beg end 'face 'completions-annotations))))) - (cond - ((eq completions-format 'one-column) - (insert "\n")) - ((eq completions-format 'vertical) - ;; Vertical format - (if (> column 0) - (forward-line) - (insert "\n")) - (setq row (1+ row))) - (t - ;; Horizontal format - ;; Next column to align to. - (setq column (+ column - ;; Round up to a whole number of columns. - (* colwidth (ceiling length colwidth)))))))))))) + (if (< wwidth (+ column (max colwidth + (if (consp str) + (apply #'+ (mapcar #'string-width str)) + (string-width str))))) + ;; No space for `str' at point, move to next line. + (progn (insert "\n") (setq column 0)) + (insert " \t") + ;; Leave the space unpropertized so that in the case we're + ;; already past the goal column, there is still + ;; a space displayed. + (set-text-properties (1- (point)) (point) + ;; We can set tab-width using + ;; completion-tab-width, but + ;; the caller can prefer using + ;; \t to align prefixes. + `(display (space :align-to ,column))) + nil)) + (setq first nil) + (completion--insert str group-fun) + ;; Next column to align to. + (setq column (+ column + ;; Round up to a whole number of columns. + (* colwidth (ceiling length colwidth)))))))) + +(defun completion--insert-vertical (strings group-fun + _length _wwidth + colwidth columns) + (let ((column 0) + (rows (/ (length strings) columns)) + (row 0) + (last-title nil) + (last-string nil) + (start-point (point)) + (next 0) (pos 0)) + (dolist (str strings) + (unless (equal last-string str) ; Remove (consecutive) duplicates. + (setq last-string str) + (when (> row rows) + (goto-char start-point) + (setq row 0 column (+ column colwidth))) + (when group-fun + (let ((title (funcall group-fun (if (consp str) (car str) str) nil))) + (unless (equal title last-title) + (setq last-title title) + (when title + ;; Align before title insertion + (when (> column 0) + (end-of-line) + (while (> (current-column) column) + (if (eobp) + (insert "\n") + (forward-line 1) + (end-of-line))) + (insert " \t") + (set-text-properties (1- (point)) (point) + `(display (space :align-to ,column)))) + (let* ((fmt completions-group-format) + (len (length fmt))) + ;; Adjust display space for columns + (when (equal (get-text-property (- len 1) 'display fmt) '(space :align-to right)) + (setq fmt (substring fmt)) + (put-text-property (- len 1) len + 'display + `(space :align-to ,(+ colwidth column -1)) + fmt)) + (insert (format fmt title))) + ;; Align after title insertion + (if (> column 0) + (forward-line) + (insert "\n")))))) + ;; Align before candidate insertion + (when (> column 0) + (end-of-line) + (while (> (current-column) column) + (if (eobp) + (insert "\n") + (forward-line 1) + (end-of-line))) + (insert " \t") + (set-text-properties (1- (point)) (point) + `(display (space :align-to ,column)))) + (completion--insert str group-fun) + ;; Align after candidate insertion + (if (> column 0) + (forward-line) + (insert "\n")) + (setq row (1+ row)))))) + +(defun completion--insert-one-column (strings group-fun &rest _) + (let ((last-title nil) (last-string nil)) + (dolist (str strings) + (unless (equal last-string str) ; Remove (consecutive) duplicates. + (setq last-string str) + (when group-fun + (let ((title (funcall group-fun (if (consp str) (car str) str) nil))) + (unless (equal title last-title) + (setq last-title title) + (when title + (insert (format completions-group-format title) "\n"))))) + (completion--insert str group-fun) + (insert "\n"))))) + +(defun completion--insert (str group-fun) + (if (not (consp str)) + (add-text-properties + (point) + (progn + (insert + (if group-fun + (funcall group-fun str 'transform) + str)) + (point)) + `(mouse-face highlight completion--string ,str)) + ;; 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))) + (completion--insert (car str) group-fun) + (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 without prefix, + ;; and when the caller doesn't use own face. + (unless (or prefix (text-property-not-all + 0 (length suffix) 'face nil suffix)) + (font-lock-prepend-text-property + beg end 'face 'completions-annotations)))))) (defvar completion-setup-hook nil "Normal hook run at the end of setting up a completion list buffer. -- 2.20.1 --------------BFABFB5E9145C030B154ECB5 Content-Type: text/x-diff; charset=UTF-8; name="0003-minibuffer-completion-help-Do-not-check-completions-.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename*0="0003-minibuffer-completion-help-Do-not-check-completions-.pa"; filename*1="tch" >From 287e77be79783e056053319477efc1f5a2e5e525 Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Sun, 2 May 2021 15:50:08 +0200 Subject: [PATCH 3/5] (minibuffer-completion-help): Do not check `completions-group` centrally The guard variable `completions-group` should be checked in each completion table individually. The guard variable `completions-detailed` variable is used in the same way. * minibuffer.el (minibuffer-completion-help): Remove check of `completions-group`. --- lisp/minibuffer.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index cf1a4350bd..b743b2bd40 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2178,8 +2178,7 @@ minibuffer-completion-help (plist-get completion-extra-properties :affixation-function))) (sort-fun (completion-metadata-get all-md 'display-sort-function)) - (group-fun (and completions-group - (completion-metadata-get all-md 'group-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 -- 2.20.1 --------------BFABFB5E9145C030B154ECB5 Content-Type: text/x-diff; charset=UTF-8; name="0004-completion-insert-vertical-Separate-groups-completel.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename*0="0004-completion-insert-vertical-Separate-groups-completel.pa"; filename*1="tch" >From 4e34bce8db0cb68ac47d4c6a42a8d37361a4dfa7 Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Sun, 2 May 2021 16:19:42 +0200 Subject: [PATCH 4/5] (completion--insert-vertical): Separate groups completely Insert the candidates vertically within the groups, but keep the groups completely separate using the full width group separators. * minibuffer.el (completion--insert-vertical): Adjust grouping. --- lisp/minibuffer.el | 108 ++++++++++++++++++++------------------------- 1 file changed, 48 insertions(+), 60 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index b743b2bd40..73a38a8137 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1866,66 +1866,54 @@ completion--insert-horizontal (defun completion--insert-vertical (strings group-fun _length _wwidth colwidth columns) - (let ((column 0) - (rows (/ (length strings) columns)) - (row 0) - (last-title nil) - (last-string nil) - (start-point (point)) - (next 0) (pos 0)) - (dolist (str strings) - (unless (equal last-string str) ; Remove (consecutive) duplicates. - (setq last-string str) - (when (> row rows) - (goto-char start-point) - (setq row 0 column (+ column colwidth))) - (when group-fun - (let ((title (funcall group-fun (if (consp str) (car str) str) nil))) - (unless (equal title last-title) - (setq last-title title) - (when title - ;; Align before title insertion - (when (> column 0) - (end-of-line) - (while (> (current-column) column) - (if (eobp) - (insert "\n") - (forward-line 1) - (end-of-line))) - (insert " \t") - (set-text-properties (1- (point)) (point) - `(display (space :align-to ,column)))) - (let* ((fmt completions-group-format) - (len (length fmt))) - ;; Adjust display space for columns - (when (equal (get-text-property (- len 1) 'display fmt) '(space :align-to right)) - (setq fmt (substring fmt)) - (put-text-property (- len 1) len - 'display - `(space :align-to ,(+ colwidth column -1)) - fmt)) - (insert (format fmt title))) - ;; Align after title insertion - (if (> column 0) - (forward-line) - (insert "\n")))))) - ;; Align before candidate insertion - (when (> column 0) - (end-of-line) - (while (> (current-column) column) - (if (eobp) - (insert "\n") - (forward-line 1) - (end-of-line))) - (insert " \t") - (set-text-properties (1- (point)) (point) - `(display (space :align-to ,column)))) - (completion--insert str group-fun) - ;; Align after candidate insertion - (if (> column 0) - (forward-line) - (insert "\n")) - (setq row (1+ row)))))) + (while strings + (let ((group nil) + (column 0) + (row 0) + (rows) + (last-string nil)) + (if group-fun + (let* ((str (car strings)) + (title (funcall group-fun (if (consp str) (car str) str) nil))) + (while (and strings + (equal title (funcall group-fun + (if (consp (car strings)) + (car (car strings)) + (car strings)) + nil))) + (push (car strings) group) + (pop strings)) + (setq group (nreverse group))) + (setq group strings + strings nil)) + (setq rows (/ (length group) columns)) + (when group-fun + (let* ((str (car group)) + (title (funcall group-fun (if (consp str) (car str) str) nil))) + (when title + (goto-char (point-max)) + (insert (format completions-group-format title) "\n")))) + (dolist (str group) + (unless (equal last-string str) ; Remove (consecutive) duplicates. + (setq last-string str) + (when (> row rows) + (forward-line (- -1 rows)) + (setq row 0 column (+ column colwidth))) + (when (> column 0) + (end-of-line) + (while (> (current-column) column) + (if (eobp) + (insert "\n") + (forward-line 1) + (end-of-line))) + (insert " \t") + (set-text-properties (1- (point)) (point) + `(display (space :align-to ,column)))) + (completion--insert str group-fun) + (if (> column 0) + (forward-line) + (insert "\n")) + (setq row (1+ row))))))) (defun completion--insert-one-column (strings group-fun &rest _) (let ((last-title nil) (last-string nil)) -- 2.20.1 --------------BFABFB5E9145C030B154ECB5 Content-Type: text/x-diff; charset=UTF-8; name="0005-group-function-Implement-generalized-action-argument.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename*0="0005-group-function-Implement-generalized-action-argument.pa"; filename*1="tch" >From 4f66c9d60573f221ead94a052ef65b699c530741 Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Sat, 8 May 2021 10:17:56 +0200 Subject: [PATCH 5/5] (group-function): Implement generalized action argument The group function takes two arguments, a first action argument and a second argument, which is either a candidate string or an alist of groups. The action argument is a symbol which can take the values: - sort: Sort groups given alist of groups. - title: Return group title given candidate. - transform: Return transformed candidate given candidate. * lisp/minibuffer.el: Use generalized group function with action argument. Update documentation. * lisp/progmodes/xref.el: Implement generalized group function. * doc/lispref/minibuf.texi: Update documentation. --- doc/lispref/minibuf.texi | 17 ++++++++++------- lisp/minibuffer.el | 40 ++++++++++++++++++++++------------------ lisp/progmodes/xref.el | 10 +++++----- 3 files changed, 37 insertions(+), 30 deletions(-) diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index aa57c2bda0..bcbd24a02a 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -1945,13 +1945,16 @@ Programmed Completion @item group-function The value should be a function for grouping the completion candidates. -The function must 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 must return a group title, -to which the candidate belongs. The returned title can also -@code{nil}. Otherwise the function must return the transformed -candidate. The transformation can for example remove a redundant -prefix, which is displayed in the group title instead. +The function must take two arguments. The first argument @var{action} +is a symbol which specifies the action to be performed. The second +argument @var{arg} is either a candidate string or an alist of +groups. If the @var{action} is @code{title}, the function must return +the group title of the candidate passed as second argument. If the +@var{action} is @code{transform}, the function must return the +transformed candidate string. The transformation can remove a +redundant prefix, which is displayed in the group title instead. If +the @var{action} is @code{sort}, the function takes an alist of groups +and must return the sorted list of groups. @item display-sort-function The value should be a function for sorting completions. The function diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 73a38a8137..41a79d6ebe 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -127,12 +127,15 @@ completion-metadata 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. The - returned title may be nil. Otherwise the function returns the - transformed candidate. The transformation can remove a redundant - prefix, which is displayed in the group title instead. + Takes two arguments. The first argument (ACTION) is a symbol which + specifies the action to be performed. The second argument is either + a candidate string or an alist of groups. If the action is `title', + the function must return the group title of the candidate passed as + second argument. If the action is `transform', the function must + return the transformed candidate string. The transformation can + remove a redundant prefix, which is displayed in the group title + instead. If the action is `sort', the function takes an alist of + groups and must return the sorted list of groups. - `display-sort-function': function to sort entries in *Completions*. Takes one argument (COMPLETIONS) and should return a new list of completions. Can operate destructively. @@ -1432,16 +1435,18 @@ minibuffer--sort-preprocess-history (substring c base-size))) hist))))) -(defun minibuffer--group-by (fun elems) - "Group ELEMS by FUN." +(defun minibuffer--group-by (group-fun elems) + "Group ELEMS by GROUP-FUN." (let ((groups)) (dolist (cand elems) - (let* ((key (funcall fun cand nil)) + (let* ((key (funcall group-fun 'title cand)) (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)))) + (apply #'nconc (funcall group-fun 'sort + (mapcar (lambda (x) (nreverse (cdr x))) + (nreverse groups)))))) (defun completion-all-sorted-completions (&optional start end) (or completion-all-sorted-completions @@ -1829,7 +1834,7 @@ completion--insert-horizontal (unless (equal last-string str) ; Remove (consecutive) duplicates. (setq last-string str) (when group-fun - (let ((title (funcall group-fun (if (consp str) (car str) str) nil))) + (let ((title (funcall group-fun 'title (if (consp str) (car str) str)))) (unless (equal title last-title) (setq last-title title) (when title @@ -1874,13 +1879,12 @@ completion--insert-vertical (last-string nil)) (if group-fun (let* ((str (car strings)) - (title (funcall group-fun (if (consp str) (car str) str) nil))) + (title (funcall group-fun 'title (if (consp str) (car str) str)))) (while (and strings - (equal title (funcall group-fun + (equal title (funcall group-fun 'title (if (consp (car strings)) (car (car strings)) - (car strings)) - nil))) + (car strings))))) (push (car strings) group) (pop strings)) (setq group (nreverse group))) @@ -1889,7 +1893,7 @@ completion--insert-vertical (setq rows (/ (length group) columns)) (when group-fun (let* ((str (car group)) - (title (funcall group-fun (if (consp str) (car str) str) nil))) + (title (funcall group-fun 'title (if (consp str) (car str) str)))) (when title (goto-char (point-max)) (insert (format completions-group-format title) "\n")))) @@ -1921,7 +1925,7 @@ completion--insert-one-column (unless (equal last-string str) ; Remove (consecutive) duplicates. (setq last-string str) (when group-fun - (let ((title (funcall group-fun (if (consp str) (car str) str) nil))) + (let ((title (funcall group-fun 'title (if (consp str) (car str) str)))) (unless (equal title last-title) (setq last-title title) (when title @@ -1936,7 +1940,7 @@ completion--insert (progn (insert (if group-fun - (funcall group-fun str 'transform) + (funcall group-fun 'transform str) str)) (point)) `(mouse-face highlight completion--string ,str)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 2a4fb2c417..813e6a8b4f 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1044,11 +1044,11 @@ 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 group 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--completing-read-group (action arg) + (pcase action + ('title (get-text-property 0 'xref--group arg)) + ('transform (substring arg (1+ (next-single-property-change 0 'xref--group arg)))) + ('sort arg))) (defun xref-show-definitions-completing-read (fetcher alist) "Let the user choose the target definition with completion. -- 2.20.1 --------------BFABFB5E9145C030B154ECB5--