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) Date: Sun, 25 Apr 2021 21:38:06 +0200 Message-ID: <0bbdeece-90d5-160c-07ec-2ad8edbf9872@daniel-mendler.de> References: Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------A8AE75AE3BD9665FA638FECF" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="36759"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Gregory Heytings , Stefan Monnier , Dmitry Gutov To: "emacs-devel@gnu.org" Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Sun Apr 25 21:39:27 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 1lakbG-0009SJ-7l for ged-emacs-devel@m.gmane-mx.org; Sun, 25 Apr 2021 21:39:26 +0200 Original-Received: from localhost ([::1]:36806 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lakbF-0002At-BD for ged-emacs-devel@m.gmane-mx.org; Sun, 25 Apr 2021 15:39:25 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:36970) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1laka9-0001gp-JY for emacs-devel@gnu.org; Sun, 25 Apr 2021 15:38:20 -0400 Original-Received: from server.qxqx.de ([2a01:4f8:121:346::180]:36975 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 1laka4-0004Fi-Lw for emacs-devel@gnu.org; Sun, 25 Apr 2021 15:38:16 -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=h0GzHOPl0ORaMFSfBf9DSmA0+GyyLwXFjGb2groNsII=; b=xL7xaeuvEMh1Y0NN8D0JZOHYAU QQh+1tUczzuj2RNZmyd7RE14sDqKuCZCWlonErSkZKCzFAp5r4KW2A81iyIgPX75wTMttqR3Am6UM y3Unid0yyaZZ4jywU19iODRIkZZKqx5wZxYZSyapDduDOHVGipYZhRG73odl5c5y21VA=; 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:268415 Archived-At: This is a multi-part message in MIME format. --------------A8AE75AE3BD9665FA638FECF Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 7bit On 4/25/21 3:32 PM, Daniel Mendler wrote: > I attached a patch which adds grouping support to the completions > buffer. The completion table can specify a `group-function` via its > completion metadata. I attached a revised patch with the following changes over the previous version: 1. Add a `completions-group` guard variable, to turn the grouping off. The setting is off by default. 2. Ensure that the original completion string is used in `choose-completion`. Attach the untransformed completion string to each completion string displayed in the *Completions* buffer. You can try the patch with the following settings and execute `xref-find-references` for example (M-?). (setq xref-show-xrefs-function #'xref-show-definitions-completing-read completions-group t completions-format 'one-column) Daniel --------------A8AE75AE3BD9665FA638FECF 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 baf8d180c41f0684bb15d87a637d36030e740665 Mon Sep 17 00:00:00 2001 From: Daniel Mendler 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): 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 candidates using the GROUP-FUN. Attach the untransformed completion string at the property `completion--string`. * lisp/simple.el (choose-completion): Retrieve the completion string by accessing 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 | 122 ++++++++++++++++++++++++++++++++------- lisp/progmodes/xref.el | 18 ++++-- lisp/simple.el | 4 +- 4 files changed, 126 insertions(+), 28 deletions(-) diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index 72f0e5878b..855b2baaf4 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..60411955e2 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. @@ -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 '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,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,8 +1880,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 +1899,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 +1992,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 +2002,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 +2016,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 +2024,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 +2137,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 +2171,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 +2232,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))) diff --git a/lisp/simple.el b/lisp/simple.el index 999755a642..e003af3fad 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -8873,9 +8873,7 @@ choose-completion (setq end (1- (point)) 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 --------------A8AE75AE3BD9665FA638FECF--