* bug#48841: [PATCH] Add new `completion-filter-completions` API and deferred highlighting
[not found] <f94541d3-5f93-9a23-8256-3bbc453f127a@yandex.ru>
@ 2021-08-11 14:16 ` Daniel Mendler
2021-08-11 16:11 ` Daniel Mendler
0 siblings, 1 reply; 4+ messages in thread
From: Daniel Mendler @ 2021-08-11 14:16 UTC (permalink / raw)
To: emacs-devel@gnu.org
Cc: 48841, Dmitry Gutov, João Távora, Stefan Monnier, 47711
[-- Attachment #1: Type: text/plain, Size: 774 bytes --]
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
[-- Attachment #2: 0001-Add-new-completion-filter-completions-API-and-deferr.patch --]
[-- Type: text/x-diff, Size: 50976 bytes --]
From e7f26abc520ac36cc154a92bfb4744837d9f7e5e Mon Sep 17 00:00:00 2001
From: Daniel Mendler <mail@daniel-mendler.de>
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 ".*[</]" "" str)
+ pred)))))
+ (point (string-search "|" string))
+ (string (string-replace "|" "" string))
+ (completion-styles (list style)))
+ (should (equal
+ (assq-delete-all
+ (if (assq 'highlight result) '-does-not-exist 'highlight)
+ (completion-filter-completions
+ string table nil point nil))
+ result))
+ (should (equal
+ (completion-all-completions
+ string table nil point)
+ (append (alist-get 'completions result)
+ (alist-get 'base result))))))
+
+(ert-deftest completion-emacs21-boundaries-test ()
+ (completion--test-boundaries 'emacs21 "before<in|put>after"
+ '("other") nil)
+ (completion--test-boundaries 'emacs21 "before<in|put>after"
+ '("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 "before<in|put>after"
+ '("other") nil)
+ (completion--test-boundaries 'emacs22 "before<in|put>after"
+ '("ainxxx" "inyy" "inzzz")
+ '((base . 7)
+ (end . 12)
+ (completions "inyy" "inzzz"))))
+
+(ert-deftest completion-basic-boundaries-test ()
+ (completion--test-boundaries 'basic "before<in|put>after"
+ '("other") nil)
+ (completion--test-boundaries 'basic "before<in|put>after"
+ '("ainput" "input" "inpux" "inxputy")
+ '((base . 7)
+ (end . 12)
+ (completions "input" "inxputy"))))
+
+(ert-deftest completion-substring-boundaries-test ()
+ (completion--test-boundaries 'substring "before<in|puts>after"
+ '("other") nil)
+ (completion--test-boundaries 'substring "before<in|puts>after"
+ '("ainputs" "inputs" "inpux" "inxputsy")
+ '((base . 7)
+ (end . 13)
+ (completions "ainputs" "inputs" "inxputsy"))))
+
+(ert-deftest completion-pcm-boundaries-test ()
+ (completion--test-boundaries 'partial-completion "before<in-p|t>after"
+ '("other") nil)
+ (completion--test-boundaries 'partial-completion "before<in-p|t>after"
+ '("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 "before<in|put>after"
+ '("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
^ permalink raw reply related [flat|nested] 4+ messages in thread