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