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.bugs,gmane.emacs.devel Subject: bug#48841: [PATCH] Add new `completion-filter-completions` API and deferred highlighting Date: Wed, 11 Aug 2021 16:16:57 +0200 Message-ID: References: Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------3147CDE26CD3C1A11006A179" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="9815"; mail-complaints-to="usenet@ciao.gmane.io" Cc: 48841@debbugs.gnu.org, Dmitry Gutov , =?UTF-8?Q?Jo=C3=A3o_?= =?UTF-8?Q?T=C3=A1vora?= , Stefan Monnier , 47711@debbugs.gnu.org To: "emacs-devel@gnu.org" Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Aug 11 16:18:25 2021 Return-path: Envelope-to: geb-bug-gnu-emacs@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 1mDp3o-0002H6-E1 for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 11 Aug 2021 16:18:24 +0200 Original-Received: from localhost ([::1]:41210 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mDp3n-0008Ht-4j for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 11 Aug 2021 10:18:23 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:40416) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mDp3S-0008Da-Bk for bug-gnu-emacs@gnu.org; Wed, 11 Aug 2021 10:18:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:52913) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mDp3S-0004iL-53 for bug-gnu-emacs@gnu.org; Wed, 11 Aug 2021 10:18:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mDp3S-0006aU-15 for bug-gnu-emacs@gnu.org; Wed, 11 Aug 2021 10:18:02 -0400 X-Loop: help-debbugs@gnu.org In-Reply-To: Resent-From: Daniel Mendler Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 11 Aug 2021 14:18:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 48841 X-GNU-PR-Package: emacs Original-Received: via spool by 48841-submit@debbugs.gnu.org id=B48841.162869143125218 (code B ref 48841); Wed, 11 Aug 2021 14:18:01 +0000 Original-Received: (at 48841) by debbugs.gnu.org; 11 Aug 2021 14:17:11 +0000 Original-Received: from localhost ([127.0.0.1]:36220 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mDp2b-0006Yd-7i for submit@debbugs.gnu.org; Wed, 11 Aug 2021 10:17:11 -0400 Original-Received: from server.qxqx.de ([178.63.65.180]:59847 helo=mail.qxqx.de) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mDp2X-0006Xz-HJ; Wed, 11 Aug 2021 10:17:08 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=qxqx.de; s=mail1392553390; h=Content-Type:MIME-Version:Date:Message-ID:Subject:From:Cc :To:Sender:Reply-To:Content-Transfer-Encoding:Content-ID:Content-Description: Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc:Resent-Message-ID: In-Reply-To:References:List-Id:List-Help:List-Unsubscribe:List-Subscribe: List-Post:List-Owner:List-Archive; bh=jI1hVGefRnIqqV63epya37LbCwXprNTn1ArIfYVUC30=; b=yxBwqrKs8WqUGCKrekohWXbjMR m08SIThso/uGJtkcBilQwb/05lPWJ9HN8PxrQOP6eiiT7fsug3Re7hkbNRdqo6Unt9xIxRfl70zp3 NsowJoPS7ZMi4mClGdJmTb33/gve/EMaHQ/WkjdJpco+1za1E/Y8Z0vV91g0rWb0eXh8=; Content-Language: en-US X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:211602 gmane.emacs.devel:272322 Archived-At: This is a multi-part message in MIME format. --------------3147CDE26CD3C1A11006A179 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 7bit I prepared a patch which provides the API `completion-filter-completions`. This function supports deferred highlighting and returns additional data with the list of matching completion candidates. The API supersedes the existing function `completion-all-completions`. The main goal of the new API is to avoid expensive string allocations and highlighting during completion. This is particularly relevant for continuously updating completion UIs like Icomplete or Vertico. Furthermore the end position of the completion boundaries is returned with the completion results. This information is not provided by the existing `completion-all-completions` API. See also the relevant bugs bug#47711 and bug#48841. I am looking forward to your feedback. Thank you! Daniel Mendler --------------3147CDE26CD3C1A11006A179 Content-Type: text/x-diff; charset=UTF-8; name="0001-Add-new-completion-filter-completions-API-and-deferr.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename*0="0001-Add-new-completion-filter-completions-API-and-deferr.pa"; filename*1="tch" >From e7f26abc520ac36cc154a92bfb4744837d9f7e5e Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Mon, 12 Jul 2021 21:40:32 +0200 Subject: [PATCH] Add new `completion-filter-completions` API and deferred highlighting Fix bug#47711. Add a new `completion-filter-completions` API, which supersedes `completion-all-completions`. The new API returns the matching completion candidates and additional data. The return value is an alist, with the keys `completions`, `base`, `end` and `highlight`. The API can be extended in a backward compatible way later on thanks to the use of an alist as return value. The `completions` value is the list of completion strings *without* applied highlighting. The completion strings are returned unmodified, which avoids allocations and results in performance gains for continuously updating completion UIs, like Icomplete or Vertico (GNU ELPA). The value `base` is the base position of the completion. Correspondingly the value `end` specifies the end position of the completion counted from the beginning of the input strng. In comparison, the old function `completion-all-completions` only returned the base position in the last cdr of the returned completions list, which complicated usage. The `end` position was not provided by `completion-all-completions`. Given the new API the `completion-base-position` can be set accurately. Finally the `highlight` value is a function taking a list of completion strings and returns a new list of new strings with highlighting applied. A continously updating UI can use the highlighting function to apply highlighting only to the visible completions. * lisp/minibuffer.el: (completion-pcm--hilit-commonality): Remove scoring computation. (completion--adjust-metadata): Rename to `completion--style-metadata` due to change of calling convention. (completion--nth-completion): Call renamed metadata adjustment function. Ignore the old property `completion--adjust-metadata`. (completion--flex-adjust-metadata): Rename function. (completion--twq-all): Attach `completion--unquoted` text property to quoted completion strings. (completion--flex-score): New optimized scoring function. Use `completion--unquoted` text property. (completion--flex-style-metadata): Use it. (completion--pattern-compiler): New function. (completion-substring--all-completions, completion--flex-score): Use it. (completion--hilit-commonality): New function. (completion-hilit-commonality): Use it. (completion--deferred-hilit): New function. (completion-basic-all-completions, completion-emacs21-all-completions, completion-emacs22-all-completions): Use it. (completion--pcm-deferred-hilit): New function. (completion-pcm-all-completions, completion-flex-all-completions, completion-initials-all-completions, completion-substring-all-completions): Use it. (completion--filter-completions): New variable to conditionally enable the new alist completions result format. This variable is for internal use to preserve the existing calling convention of the completion style `all` functions. (completion-filter-completions): New API which returns the completion strings and additional data as an an alist. Transparently convert old-fashioned completion style results to the new format. (completion-all-completions): Transparently downgrade the new-fashioned completion style result to the old list format. (minibuffer-completion-help): Use the new API, set `completion-base-position` correctly. (completion-try-completion, completion-all-completions): Update doc string. (completion--replace): Remove unnecessary property removal. * test/lisp/minibuffer-tests.el: (completion--pcm-score): Remove obsolete function. (completion-*-test-*): Remove obsolete functions, rename. (completion-flex-score-test-*): Add new scoring test functions. (completion--test-style): New test helper function. (completion-*-style-test): Add new API tests for each built-in completion style. (completion--test-boundaries): New test helper function. (completion-*-boundaries-test): New boundary tests for each built-in completion style. (completion-filter-completions-highlight-test): New API test. (completion-emacs22orig-all-completions): New function. (completion-upgrade-return-type-test): New test of transparent completion style return value upgrade. --- lisp/minibuffer.el | 453 +++++++++++++++++++++++----------- test/lisp/minibuffer-tests.el | 257 +++++++++++++++---- 2 files changed, 516 insertions(+), 194 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 9f327df28f..ba8855c4ea 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -692,6 +692,10 @@ completion--twq-all 'completions-common-part) qprefix)))) (qcompletion (concat qprefix qnew))) + ;; Attach unquoted completion string, which is needed + ;; to score the completion in `completion--flex-score'. + (put-text-property 0 1 'completion--unquoted + completion qcompletion) ;; FIXME: Similarly here, Cygwin's mapping trips this ;; assertion. ;;(cl-assert @@ -1035,6 +1039,17 @@ completion--styles (delete-dups (append (cdr over) (copy-sequence completion-styles))) completion-styles))) +(defvar completion--filter-completions nil + "Enable the new completions return value format. +If this variable is non-nil the `all-completions' function of a +completion style should return the results in the new alist format of +`completion-filter-completions'. This variable is purely needed to +for backward compatibility of the existing builtin completion style +functions. New completion style functions may always return their +results in the new alist format, since `completion-all-completions' +transparently converts back to the old improper list of completions +with base size in the last cdr.") + (defun completion--nth-completion (n string table pred point metadata) "Call the Nth method of completion styles." ;; We provide special support for quoting/unquoting here because it cannot @@ -1061,6 +1076,15 @@ completion--nth-completion ;; the original table, in that case! (functionp table)) (let ((new (funcall table string point 'completion--unquote))) + ;; FIXME For now do not attempt deferred highlighting if + ;; quoting is used. Not doing deferred highlighting is + ;; not too severe in this case, since + ;; `completion--twq-all' is already an expensive + ;; function, which allocates all completion strings. In + ;; contrast to plain completion tables, the savings of + ;; deferred highlighting would be minimal in the case of + ;; quoted completion tables. + (setq completion--filter-completions nil) (setq string (pop new)) (setq table (pop new)) (setq point (pop new)) @@ -1074,9 +1098,10 @@ completion--nth-completion string table pred point))) (and probe (cons probe style)))) (completion--styles md))) - (adjust-fn (get (cdr result-and-style) 'completion--adjust-metadata))) - (when (and adjust-fn metadata) - (setcdr metadata (cdr (funcall adjust-fn metadata)))) + (style-md (get (cdr result-and-style) 'completion--style-metadata))) + (when (and style-md metadata) + (setcdr metadata (cdr (funcall style-md + string table pred point metadata)))) (if requote (funcall requote (car result-and-style) n) (car result-and-style)))) @@ -1084,22 +1109,64 @@ completion--nth-completion (defun completion-try-completion (string table pred point &optional metadata) "Try to complete STRING using completion table TABLE. Only the elements of table that satisfy predicate PRED are considered. -POINT is the position of point within STRING. -The return value can be either nil to indicate that there is no completion, -t to indicate that STRING is the only possible completion, -or a pair (NEWSTRING . NEWPOINT) of the completed result string together with -a new position for point." +POINT is the position of point within STRING. The return value can be +either nil to indicate that there is no completion, t to indicate that +STRING is the only possible completion, or a pair (NEWSTRING . NEWPOINT) +of the completed result string together with a new position for point. +The METADATA may be modified by the completion style." (completion--nth-completion 1 string table pred point metadata)) (defun completion-all-completions (string table pred point &optional metadata) "List the possible completions of STRING in completion table TABLE. Only the elements of table that satisfy predicate PRED are considered. -POINT is the position of point within STRING. -The return value is a list of completions and may contain the base-size -in the last `cdr'." - ;; FIXME: We need to additionally return the info needed for the - ;; second part of completion-base-position. - (completion--nth-completion 2 string table pred point metadata)) +POINT is the position of point within STRING. The return value is a +list of completions and may contain the base-size in the last `cdr'. +The METADATA may be modified by the completion style. This function +has been superseded by `completion-filter-completions', which returns +richer information and supports deferred candidate highlighting." + (let ((completion--filter-completions nil) + (result (completion--nth-completion 2 string table + pred point metadata))) + (if (and result (consp (car result))) + ;; Give the completion styles some freedom! + ;; If they are targeting Emacs 28 upwards only, they + ;; may always return a result with deferred + ;; highlighting. We convert back to the old format + ;; here by applying the highlighting eagerly. + (nconc (funcall (cdr (assq 'highlight result)) + (cdr (assq 'completions result))) + (cdr (assq 'base result))) + result))) + +(defun completion-filter-completions (string table pred point metadata) + "Filter the possible completions of STRING in completion table TABLE. +Only the elements of table that satisfy predicate PRED are considered. +POINT is the position of point within STRING. The METADATA may be +modified by the completion style. The return value is a alist with +the keys: + +- base: Base position of the completion (from the start of STRING) +- end: End position of the completion (from the start of STRING) +- highlight: Highlighting function taking a list of completions and + returning a new list of new strings with applied highlighting. +- completions: The list of completions. + +This function supersedes the function `completion-all-completions'." + (let* ((completion--filter-completions t) + (result (completion--nth-completion 2 string table + pred point metadata))) + (if (and result (not (consp (car result)))) + ;; Deferred highlighting has been requested, but the completion + ;; style returned a non-deferred result. Convert the result to the + ;; new alist format. + (let* ((last (last result)) + (base (or (cdr last) 0))) + (setcdr last nil) + `((base . ,base) + (end . ,(length string)) + (highlight . identity) + (completions . ,result))) + result))) (defun minibuffer--bitset (modified completions exact) (logior (if modified 4 0) @@ -1114,9 +1181,8 @@ completion--replace ;; include upon insertion. (if minibuffer-allow-text-properties ;; If we're preserving properties, then just remove the faces - ;; and other properties added by the completion machinery. - (remove-text-properties 0 (length newtext) '(face completion-score) - newtext) + ;; added by the completion machinery. + (remove-text-properties 0 (length newtext) '(face nil) newtext) ;; Remove all text properties. (set-text-properties 0 (length newtext) nil newtext)) ;; Maybe this should be in subr.el. @@ -2021,34 +2087,48 @@ completion-hilit-commonality It returns a list with font-lock properties applied to each element, and with BASE-SIZE appended as the last element." (when completions - (let ((com-str-len (- prefix-len (or base-size 0)))) - (nconc - (mapcar - (lambda (elem) - (let ((str - ;; Don't modify the string itself, but a copy, since the - ;; the string may be read-only or used for other purposes. - ;; Furthermore, since `completions' may come from - ;; display-completion-list, `elem' may be a list. - (if (consp elem) - (car (setq elem (cons (copy-sequence (car elem)) - (cdr elem)))) - (setq elem (copy-sequence elem))))) - (font-lock-prepend-text-property - 0 - ;; If completion-boundaries returns incorrect - ;; values, all-completions may return strings - ;; that don't contain the prefix. - (min com-str-len (length str)) - 'face 'completions-common-part str) - (if (> (length str) com-str-len) - (font-lock-prepend-text-property com-str-len (1+ com-str-len) - 'face - 'completions-first-difference - str))) - elem) - completions) - base-size)))) + (nconc + (completion--hilit-commonality (- prefix-len (or base-size 0)) completions) + base-size))) + +(defun completion--hilit-commonality (com-size completions) + (mapcar + (lambda (elem) + (let ((str + ;; Don't modify the string itself, but a copy, since the + ;; the string may be read-only or used for other purposes. + ;; Furthermore, since `completions' may come from + ;; display-completion-list, `elem' may be a list. + (if (consp elem) + (car (setq elem (cons (copy-sequence (car elem)) + (cdr elem)))) + (setq elem (copy-sequence elem))))) + (font-lock-prepend-text-property + 0 + ;; If completion-boundaries returns incorrect + ;; values, all-completions may return strings + ;; that don't contain the prefix. + (min com-size (length str)) + 'face 'completions-common-part str) + (if (> (length str) com-size) + (font-lock-prepend-text-property com-size (1+ com-size) + 'face + 'completions-first-difference + str))) + elem) + completions)) + +(defun completion--deferred-hilit (completions prefix-len base end) + "Return completions in old format or new alist format. +If `completion--filter-completions' is non-nil use the new format." + (if completion--filter-completions + (when completions + `((base . ,base) + (end . ,end) + (highlight . ,(apply-partially #'completion--hilit-commonality + (- prefix-len base))) + (completions . ,completions))) + (completion-hilit-commonality completions prefix-len base))) (defun display-completion-list (completions &optional common-substring group-fun) "Display the list of completions, COMPLETIONS, using `standard-output'. @@ -2163,15 +2243,16 @@ minibuffer-completion-help (end (or end (point-max))) (string (buffer-substring start end)) (md (completion--field-metadata start)) - (completions (completion-all-completions - string - minibuffer-completion-table - minibuffer-completion-predicate - (- (point) start) - md))) + (filtered-completions (completion-filter-completions + string + minibuffer-completion-table + minibuffer-completion-predicate + (- (point) start) + md)) + (completions (alist-get 'completions filtered-completions))) (message nil) (if (or (null completions) - (and (not (consp (cdr completions))) + (and (not (cdr completions)) (equal (car completions) string))) (progn ;; If there are no completions, or if the current input is already @@ -2181,8 +2262,7 @@ minibuffer-completion-help (completion--message (if completions "Sole completion" "No completions"))) - (let* ((last (last completions)) - (base-size (or (cdr last) 0)) + (let* ((base-size (alist-get 'base filtered-completions)) (prefix (unless (zerop base-size) (substring string 0 base-size))) (all-md (completion--metadata (buffer-substring-no-properties start (point)) @@ -2226,9 +2306,10 @@ minibuffer-completion-help (body-function . ,#'(lambda (_window) (with-current-buffer mainbuf - ;; Remove the base-size tail because `sort' requires a properly - ;; nil-terminated list. - (when last (setcdr last nil)) + ;; Apply highlighting + (setq completions + (funcall (alist-get 'highlight filtered-completions) + completions)) ;; Sort first using the `display-sort-function'. ;; FIXME: This function is for the output of @@ -2267,13 +2348,10 @@ minibuffer-completion-help completions)))) (with-current-buffer standard-output - (setq-local completion-base-position - (list (+ start base-size) - ;; FIXME: We should pay attention to completion - ;; boundaries here, but currently - ;; completion-all-completions does not give us the - ;; necessary information. - end)) + (setq-local + completion-base-position + (list (+ start base-size) + (+ start (alist-get 'end filtered-completions)))) (setq-local completion-list-insert-choice-function (let ((ctable minibuffer-completion-table) (cpred minibuffer-completion-predicate) @@ -3223,10 +3301,11 @@ completion-emacs21-try-completion completion))) (defun completion-emacs21-all-completions (string table pred _point) - (completion-hilit-commonality + (completion--deferred-hilit (all-completions string table pred) (length string) - (car (completion-boundaries string table pred "")))) + (car (completion-boundaries string table pred "")) + (length string))) (defun completion-emacs22-try-completion (string table pred point) (let ((suffix (substring string point)) @@ -3249,11 +3328,12 @@ completion-emacs22-try-completion (cons (concat completion suffix) (length completion))))) (defun completion-emacs22-all-completions (string table pred point) - (let ((beforepoint (substring string 0 point))) - (completion-hilit-commonality + (let* ((beforepoint (substring string 0 point)) + (afterpoint (substring string point)) + (bounds (completion-boundaries beforepoint table pred afterpoint))) + (completion--deferred-hilit (all-completions beforepoint table pred) - point - (car (completion-boundaries beforepoint table pred ""))))) + point (car bounds) (+ point (cdr bounds))))) ;;; Basic completion. @@ -3312,7 +3392,7 @@ completion-basic-all-completions 'point (substring afterpoint 0 (cdr bounds))))) (all (completion-pcm--all-completions prefix pattern table pred))) - (completion-hilit-commonality all point (car bounds)))) + (completion--deferred-hilit all point (car bounds) (+ point (cdr bounds))))) ;;; Partial-completion-mode style completion. @@ -3504,13 +3584,25 @@ flex-score-match-tightness than the latter (which has two \"holes\" and three one-letter-long matches).") +(defun completion-pcm--deferred-hilit (pattern completions base end) + "Return completions in old format or new alist format. +If `completion--filter-completions' is non-nil use the new format." + (when completions + (if completion--filter-completions + `((base . ,base) + (end . ,end) + (highlight . ,(apply-partially + #'completion-pcm--hilit-commonality + pattern)) + (completions . ,completions)) + (nconc (completion-pcm--hilit-commonality pattern completions) base)))) + (defun completion-pcm--hilit-commonality (pattern completions) "Show where and how well PATTERN matches COMPLETIONS. PATTERN, a list of symbols and strings as seen `completion-pcm--merge-completions', is assumed to match every string in COMPLETIONS. Return a deep copy of COMPLETIONS where -each string is propertized with `completion-score', a number -between 0 and 1, and with faces `completions-common-part', +each string is propertized with faces `completions-common-part', `completions-first-difference' in the relevant segments." (when completions (let* ((re (completion-pcm--pattern->regex pattern 'group)) @@ -3525,6 +3617,54 @@ completion-pcm--hilit-commonality (error "Internal error: %s does not match %s" re str)) (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0))) (match-end (match-end 0)) + (md (cddr (setq last-md (match-data t last-md)))) + (from 0)) + (while md + (add-face-text-property from (pop md) + 'completions-common-part + nil str) + (setq from (pop md))) + ;; If `pattern' doesn't have an explicit trailing any, the + ;; regex `re' won't produce match data representing the + ;; region after the match. We need to account to account + ;; for that extra bit of match (bug#42149). + (unless (= from match-end) + (add-face-text-property from match-end + 'completions-common-part + nil str)) + (if (> (length str) pos) + (add-face-text-property + pos (1+ pos) + 'completions-first-difference + nil str))) + str) + completions)))) + +(defun completion--flex-score (pattern completions) + "Compute how well PATTERN matches COMPLETIONS. +PATTERN, a list of strings is assumed to match every string in +COMPLETIONS. Return a copy of COMPLETIONS where each element is +a pair of a score and the completion string. The score lies in +the range between -1 and 0, where -1 corresponds to the full +match." + (when completions + (let* ((re (completion-pcm--pattern->regex pattern 'group)) + (case-fold-search completion-ignore-case) + last-md) + (mapcar + (lambda (str) + ;; The flex completion style requires the completion to match + ;; the pattern to compute the scoring. For quoted completion + ;; tables the completions are matched against the *unquoted + ;; input string*. However `completion-all-completions' and + ;; `completion-filter-completions' return a list of *quoted + ;; completions*, which is subsequently sorted. Therefore we + ;; obtain the unquoted completion string which is stored in + ;; the text property `completion--unquoted'. + (setq str (or (get-text-property 0 'completion--unquoted str) str)) + (unless (string-match re str) + (error "Internal error: %s does not match %s" re str)) + (let* ((match-end (match-end 0)) (md (cddr (setq last-md (match-data t last-md)))) (from 0) (end (length str)) @@ -3564,13 +3704,10 @@ completion-pcm--hilit-commonality ;; , where "len" is the string's length. (score-numerator 0) (score-denominator 0) - (last-b 0) - (update-score-and-face - (lambda (a b) - "Update score and face given match range (A B)." - (add-face-text-property a b - 'completions-common-part - nil str) + (last-b 0)) + (while md + (let ((a from) + (b (pop md))) (setq score-numerator (+ score-numerator (- b a))) (unless (or (= a last-b) @@ -3583,26 +3720,29 @@ completion-pcm--hilit-commonality (/ 1.0 flex-score-match-tightness))))) (setq - last-b b)))) - (while md - (funcall update-score-and-face from (pop md)) + last-b b)) (setq from (pop md))) ;; If `pattern' doesn't have an explicit trailing any, the ;; regex `re' won't produce match data representing the ;; region after the match. We need to account to account ;; for that extra bit of match (bug#42149). (unless (= from match-end) - (funcall update-score-and-face from match-end)) - (if (> (length str) pos) - (add-face-text-property - pos (1+ pos) - 'completions-first-difference - nil str)) - (unless (zerop (length str)) - (put-text-property - 0 1 'completion-score - (/ score-numerator (* end (1+ score-denominator)) 1.0) str))) - str) + (let ((a from) + (b match-end)) + (setq + score-numerator (+ score-numerator (- b a))) + (unless (or (= a last-b) + (zerop last-b) + (= a (length str))) + (setq + score-denominator (+ score-denominator + 1 + (expt (- a last-b 1) + (/ 1.0 + flex-score-match-tightness))))) + (setq + last-b b))) + (cons (- (/ score-numerator (* end (1+ score-denominator)) 1.0)) str))) completions)))) (defun completion-pcm--find-all-completions (string table pred point @@ -3700,11 +3840,11 @@ completion-pcm--find-all-completions (list pattern all prefix suffix))))) (defun completion-pcm-all-completions (string table pred point) - (pcase-let ((`(,pattern ,all ,prefix ,_suffix) + (pcase-let ((`(,pattern ,all ,prefix ,suffix) (completion-pcm--find-all-completions string table pred point))) - (when all - (nconc (completion-pcm--hilit-commonality pattern all) - (length prefix))))) + (completion-pcm--deferred-hilit pattern all + (length prefix) + (- (length string) (length suffix))))) (defun completion--common-suffix (strs) "Return the common suffix of the strings STRS." @@ -3885,8 +4025,8 @@ completion-pcm-try-completion ;;; Substring completion ;; Mostly derived from the code of `basic' completion. -(defun completion-substring--all-completions - (string table pred point &optional transform-pattern-fn) +(defun completion--pattern-compiler + (string table pred point transform-pattern-fn) "Match the presumed substring STRING to the entries in TABLE. Respect PRED and POINT. The pattern used is a PCM-style substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if @@ -3904,12 +4044,23 @@ completion-substring--all-completions (pattern (completion-pcm--optimize-pattern (if transform-pattern-fn (funcall transform-pattern-fn pattern) - pattern))) - (all (completion-pcm--all-completions prefix pattern table pred))) - (list all pattern prefix suffix (car bounds)))) + pattern)))) + (list pattern prefix suffix))) + +(defun completion-substring--all-completions + (string table pred point &optional transform-pattern-fn) + "Match the presumed substring STRING to the entries in TABLE. +Respect PRED and POINT. The pattern used is a PCM-style +substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if +that is non-nil." + (pcase-let (((and result `(,pattern ,prefix ,_suffix)) + (completion--pattern-compiler string table pred point + transform-pattern-fn))) + (cons (completion-pcm--all-completions prefix pattern table pred) + result))) (defun completion-substring-try-completion (string table pred point) - (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds) + (pcase-let ((`(,all ,pattern ,prefix ,suffix) (completion-substring--all-completions string table pred point))) (if minibuffer-completing-file-name @@ -3917,12 +4068,12 @@ completion-substring-try-completion (completion-pcm--merge-try pattern all prefix suffix))) (defun completion-substring-all-completions (string table pred point) - (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds) + (pcase-let ((`(,all ,pattern ,prefix ,suffix) (completion-substring--all-completions string table pred point))) - (when all - (nconc (completion-pcm--hilit-commonality pattern all) - (length prefix))))) + (completion-pcm--deferred-hilit pattern all + (length prefix) + (- (length string) (length suffix))))) ;;; "flex" completion, also known as flx/fuzzy/scatter completion ;; Completes "foo" to "frodo" and "farfromsober" @@ -3932,42 +4083,40 @@ completion-flex-nospace :version "27.1" :type 'boolean) -(put 'flex 'completion--adjust-metadata 'completion--flex-adjust-metadata) - -(defun completion--flex-adjust-metadata (metadata) - (cl-flet - ((compose-flex-sort-fn - (existing-sort-fn) ; wish `cl-flet' had proper indentation... - (lambda (completions) - (let ((pre-sorted - (if existing-sort-fn - (funcall existing-sort-fn completions) - completions))) - (cond - ((or (not (window-minibuffer-p)) - ;; JT@2019-12-23: FIXME: this is still wrong. What - ;; we need to test here is "some input that actually - ;; leads to flex filtering", not "something after - ;; the minibuffer prompt". Among other - ;; inconsistencies, the latter is always true for - ;; file searches, meaning the next clauses will be - ;; ignored. - (> (point-max) (minibuffer-prompt-end))) - (sort - pre-sorted - (lambda (c1 c2) - (let ((s1 (get-text-property 0 'completion-score c1)) - (s2 (get-text-property 0 'completion-score c2))) - (> (or s1 0) (or s2 0)))))) - (t pre-sorted)))))) - `(metadata - (display-sort-function - . ,(compose-flex-sort-fn - (completion-metadata-get metadata 'display-sort-function))) - (cycle-sort-function - . ,(compose-flex-sort-fn - (completion-metadata-get metadata 'cycle-sort-function))) - ,@(cdr metadata)))) +(put 'flex 'completion--style-metadata 'completion--flex-style-metadata) + +(defun completion--flex-style-metadata (string table pred point metadata) + ;; Use the modified flex sorting function only for non-empty input. + ;; In an older version of `completion--flex-adjust-metadata', the + ;; check (> (point-max) (minibuffer-prompt-end))) was used instead. + (unless (eq string "") + (let ((pattern (car (completion--pattern-compiler + string table pred point + #'completion-flex--make-flex-pattern)))) + (cl-flet + ((compose-flex-sort-fn + (existing-sort-fn) ; wish `cl-flet' had proper indentation... + (lambda (completions) + (let* ((sorted (sort (completion--flex-score + pattern + (if existing-sort-fn + (funcall existing-sort-fn completions) + completions)) + #'car-less-than-car)) + (cell sorted)) + ;; Remove score decorations, reuse the list to avoid allocations. + (while cell + (setcar cell (cdar cell)) + (pop cell)) + sorted)))) + `(metadata + (display-sort-function + . ,(compose-flex-sort-fn + (completion-metadata-get metadata 'display-sort-function))) + (cycle-sort-function + . ,(compose-flex-sort-fn + (completion-metadata-get metadata 'cycle-sort-function))) + ,@(cdr metadata)))))) (defun completion-flex--make-flex-pattern (pattern) "Convert PCM-style PATTERN into PCM-style flex pattern. @@ -3989,7 +4138,7 @@ completion-flex--make-flex-pattern (defun completion-flex-try-completion (string table pred point) "Try to flex-complete STRING in TABLE given PRED and POINT." (unless (and completion-flex-nospace (string-search " " string)) - (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds) + (pcase-let ((`(,all ,pattern ,prefix ,suffix) (completion-substring--all-completions string table pred point #'completion-flex--make-flex-pattern))) @@ -4006,13 +4155,13 @@ completion-flex-try-completion (defun completion-flex-all-completions (string table pred point) "Get flex-completions of STRING in TABLE, given PRED and POINT." (unless (and completion-flex-nospace (string-search " " string)) - (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds) + (pcase-let ((`(,all ,pattern ,prefix ,suffix) (completion-substring--all-completions string table pred point #'completion-flex--make-flex-pattern))) - (when all - (nconc (completion-pcm--hilit-commonality pattern all) - (length prefix)))))) + (completion-pcm--deferred-hilit pattern all + (length prefix) + (- (length string) (length suffix)))))) ;; Initials completion ;; Complete /ums to /usr/monnier/src or lch to list-command-history. @@ -4049,7 +4198,11 @@ completion-initials-expand (defun completion-initials-all-completions (string table pred _point) (let ((newstr (completion-initials-expand string table pred))) (when newstr - (completion-pcm-all-completions newstr table pred (length newstr))))) + (pcase-let ((`(,pattern ,all ,prefix ,_suffix) + (completion-pcm--find-all-completions newstr table + pred (length newstr)))) + (completion-pcm--deferred-hilit pattern all + (length prefix) (length string)))))) (defun completion-initials-try-completion (string table pred _point) (let ((newstr (completion-initials-expand string table pred))) diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index c3ba8f9a92..4ebf27fd1d 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -188,10 +188,6 @@ completion-all-sorted-completions '("some/alpha" "base/epsilon" "base/delta")) `("epsilon" "delta" "beta" "alpha" "gamma" . 5)))) -(defun completion--pcm-score (comp) - "Get `completion-score' from COMP." - (get-text-property 0 'completion-score comp)) - (defun completion--pcm-first-difference-pos (comp) "Get `completions-first-difference' from COMP." (cl-loop for pos = (next-single-property-change 0 'face comp) @@ -215,25 +211,12 @@ completion-pcm-test-2 "barfoobar"))) (ert-deftest completion-pcm-test-3 () - ;; Full match! - (should (eql - (completion--pcm-score - (car (completion-pcm-all-completions - "R" '("R" "hello") nil 1))) - 1.0))) - -(ert-deftest completion-pcm-test-4 () - ;; One fourth of a match and no match due to point being at the end - (should (eql - (completion--pcm-score - (car (completion-pcm-all-completions - "RO" '("RaOb") nil 1))) - (/ 1.0 4.0))) + ;; No match due to point being at the end (should (null (completion-pcm-all-completions "RO" '("RaOb") nil 2)))) -(ert-deftest completion-pcm-test-5 () +(ert-deftest completion-pcm-test-4 () ;; Since point is at the beginning, there is nothing that can really ;; be typed anymore (should (null @@ -241,7 +224,7 @@ completion-pcm-test-5 (car (completion-pcm-all-completions "f" '("few" "many") nil 0)))))) -(ert-deftest completion-pcm-test-6 () +(ert-deftest completion-pcm-test-5 () ;; Wildcards and delimiters work (should (equal (car (completion-pcm-all-completions @@ -252,26 +235,12 @@ completion-pcm-test-6 "li-pac*" '("do-not-list-packages") nil 7))))) (ert-deftest completion-substring-test-1 () - ;; One third of a match! (should (equal (car (completion-substring-all-completions "foo" '("hello" "world" "barfoobar") nil 3)) - "barfoobar")) - (should (eql - (completion--pcm-score - (car (completion-substring-all-completions - "foo" '("hello" "world" "barfoobar") nil 3))) - (/ 1.0 3.0)))) + "barfoobar"))) (ert-deftest completion-substring-test-2 () - ;; Full match! - (should (eql - (completion--pcm-score - (car (completion-substring-all-completions - "R" '("R" "hello") nil 1))) - 1.0))) - -(ert-deftest completion-substring-test-3 () ;; Substring match (should (equal (car (completion-substring-all-completions @@ -281,7 +250,7 @@ completion-substring-test-3 (car (completion-substring-all-completions "custgroup" '("customize-group") nil 5))))) -(ert-deftest completion-substring-test-4 () +(ert-deftest completion-substring-test-3 () ;; `completions-first-difference' should be at the right place (should (eql (completion--pcm-first-difference-pos @@ -306,14 +275,6 @@ completion-flex-test-1 "fabrobazo"))) (ert-deftest completion-flex-test-2 () - ;; Full match! - (should (eql - (completion--pcm-score - (car (completion-flex-all-completions - "R" '("R" "hello") nil 1))) - 1.0))) - -(ert-deftest completion-flex-test-3 () ;; Another fuzzy match, but more of a "substring" one (should (equal (car (completion-flex-all-completions @@ -331,5 +292,213 @@ completion-flex-test-3 "custgroup" '("customize-group-other-window") nil 9))) 15))) +(ert-deftest completion-flex-score-test-1 () + ;; Full match! + (should (equal + (completion--flex-score '(prefix "R") '("R")) + (list (cons -1.0 "R"))))) + +(ert-deftest completion-flex-score-test-2 () + ;; One third and half of a match! + (should (equal + (completion--flex-score '(prefix "foo") + '("barfoobar" "fooboo")) + (list (cons (/ -1.0 3.0) "barfoobar") + (cons (/ -1.0 2.0) "fooboo"))))) + +(ert-deftest completion-flex-score-test-3 () + ;; One fourth of a match + (should (eql + (caar (completion--flex-score '(prefix "R" point "O") + '("RaOb"))) + (/ -1.0 4.0)))) + +(ert-deftest completion-flex-score-test-4 () + ;; For quoted completion tables, score the unquoted completion string. + (should (equal + (completion--flex-score + '(prefix "R") + (list (propertize "X" 'completion--unquoted "R"))) + (list (cons -1.0 "R"))))) + +(defun completion--test-style (style string point table filtered) + (let* ((completion-styles (list style)) + (pred (lambda (x) (not (string-search "!" x)))) + (result (completion-filter-completions + string table pred point nil))) + (should (equal (alist-get 'base result) 0)) + (should (equal (alist-get 'end result) (length string))) + (should (equal (alist-get 'completions result) filtered)) + (should (not (memq (alist-get 'highlight result) '(nil identity)))) + (should (equal (completion-all-completions string table pred point) + (append filtered 0))))) + +(ert-deftest completion-basic-style-test-1 () + ;; point at the beginning |foo + (completion--test-style 'basic "foo" 0 + '("foobar" "foo!" "barfoo" "xfooy" "boobar") + '("foobar" "barfoo" "xfooy"))) + +(ert-deftest completion-basic-style-test-2 () + ;; point foo + (completion--test-style 'basic "foo" 2 + '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar") + '("foobar"))) + +(ert-deftest completion-substring-style-test () + (completion--test-style 'substring "foo" 1 + '("foobar" "foo!" "barfoo" "xfooy" "boobar") + '("foobar" "barfoo" "xfooy"))) + +(ert-deftest completion-emacs21-style-test () + (completion--test-style 'emacs21 "foo" 1 + '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar") + '("foobar"))) + +(ert-deftest completion-emacs22-style-test () + (completion--test-style 'emacs22 "fo0" 1 + '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar") + '("foobar" "fobar"))) ;; suffix ignored completely + +(ert-deftest completion-flex-style-test () + (completion--test-style 'flex "abc" 1 + '("abc" "abc!" "xaybzc" "xaybz") + '("abc" "xaybzc"))) + +(ert-deftest completion-initials-style-test () + (completion--test-style 'initials "abc" 1 + '("a-b-c" "a-b-c!" "ax-by-cz" "xax-by-cz") + '("a-b-c" "ax-by-cz"))) + +(ert-deftest completion-pcm-style-test () + (completion--test-style 'partial-completion "ax-b-c" 1 + '("ax-b-c" "ax-b-c!" "ax-by-cz" "xax-by-cz") + '("ax-b-c" "ax-by-cz"))) + +(ert-deftest completion-filter-completions-highlight-test () + ;; point at the beginning |foo + (let* ((completion-styles '(basic)) + (result (completion-filter-completions + "foo" '("foobar" "fbarfoo" "fxfooy" "bar") + nil 1 nil))) + (should (equal + (format "%S" (alist-get 'completions result)) + (format "%S" '("foobar" "fbarfoo" "fxfooy")))) + (should (equal + (format "%S" (funcall (alist-get 'highlight result) + (alist-get 'completions result))) + (format "%S" + '(#("foobar" 0 1 (face (completions-common-part)) + 1 2 (face (completions-first-difference))) + #("fbarfoo" 0 1 (face (completions-common-part)) + 1 2 (face (completions-first-difference))) + #("fxfooy" 0 1 (face (completions-common-part)) + 1 2 (face (completions-first-difference))))))))) + +(defun completion--test-boundaries (style string table result) + (let ((table + (lambda (str pred action) + (pcase action + (`(boundaries . ,suffix) `(boundaries + ,(1+ (string-match-p "<\\|/" str)) + . ,(or (string-search ">" suffix) (length suffix)))) + (_ (complete-with-action action table + (replace-regexp-in-string ".*[after" + '("other") nil) + (completion--test-boundaries 'emacs21 "beforeafter" + '("ainput>after" "input>after" "inpux>after" + "inxputy>after" "input>after2") + '((base . 7) + (end . 18) + (completions "input>after" "input>after2")))) + +(ert-deftest completion-emacs22-boundaries-test () + (completion--test-boundaries 'emacs22 "beforeafter" + '("other") nil) + (completion--test-boundaries 'emacs22 "beforeafter" + '("ainxxx" "inyy" "inzzz") + '((base . 7) + (end . 12) + (completions "inyy" "inzzz")))) + +(ert-deftest completion-basic-boundaries-test () + (completion--test-boundaries 'basic "beforeafter" + '("other") nil) + (completion--test-boundaries 'basic "beforeafter" + '("ainput" "input" "inpux" "inxputy") + '((base . 7) + (end . 12) + (completions "input" "inxputy")))) + +(ert-deftest completion-substring-boundaries-test () + (completion--test-boundaries 'substring "beforeafter" + '("other") nil) + (completion--test-boundaries 'substring "beforeafter" + '("ainputs" "inputs" "inpux" "inxputsy") + '((base . 7) + (end . 13) + (completions "ainputs" "inputs" "inxputsy")))) + +(ert-deftest completion-pcm-boundaries-test () + (completion--test-boundaries 'partial-completion "beforeafter" + '("other") nil) + (completion--test-boundaries 'partial-completion "beforeafter" + '("ain-pu-ts" "in-pts" "in-pu-ts" "in-px" "inx-ptsy") + '((base . 7) + (end . 12) + (completions "in-pts" "in-pu-ts" "inx-ptsy")))) + +(ert-deftest completion-initials-boundaries-test () + (completion--test-boundaries 'initials "/ip|t" + '("other") nil) + (completion--test-boundaries 'initials "/ip|t" + '("ain/pu/ts" "in/pts" "in/pu/ts" "a/in/pu/ts" + "in/pu/ts/foo" "in/px" "inx/ptsy") + '((base . 1) + (end . 4) + (completions "in/pu/ts" "in/pu/ts/foo")))) + +(defun completion-emacs22orig-all-completions (string table pred point) + (let ((beforepoint (substring string 0 point))) + (completion-hilit-commonality + (all-completions beforepoint table pred) + point + (car (completion-boundaries beforepoint table pred ""))))) + +(ert-deftest completion-upgrade-return-type-test () + ;; Test transparent upgrade of old completion style return value + ;; to new return value format. + (let ((completion-styles-alist + '((emacs22orig completion-emacs22-try-completion + completion-emacs22orig-all-completions nil)))) + (completion--test-boundaries 'emacs22orig "beforeafter" + '("ainxxx" "inyy" "inzzz") + '((base . 7) + ;; 18 is incorrect, should be 12! + ;; But the information is not available + ;; due to the completion-style upgrade. + (end . 18) + ;; Identity highlighting function. + (highlight . identity) + (completions "inyy" "inzzz"))))) + (provide 'minibuffer-tests) ;;; minibuffer-tests.el ends here -- 2.20.1 --------------3147CDE26CD3C1A11006A179--