bug#48841: [PATCH VERSION 2] Add new `completion-filter-completions` API and deferred highlighting

[Daniel Mendler <mail@daniel-mendler.de>]

[-- Attachment #1: Type: text/plain, Size: 290 bytes --]

I attached the overhauled patch, which addresses most of the comments by
Eli.  In comparison to my last patch, the patch is fully backward
compatible and preserves all existing tests.  As before, there are tests
which check the new functionality for each existing completion style.

Daniel

[-- Attachment #2: 0001-Add-new-completion-filter-completions-API-and-deferr.patch --]
[-- Type: text/x-diff, Size: 53501 bytes --]

From 30ca42b49d5b5316abb3ebad38b0e9629eb52920 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
relative to the beginning of the input string.  Correspondingly the
value 'end' specifies the end position of the completion relative to
the beginning of the input string.  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--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-1): Extract new function from
'completion-pcm--hilit-commonality'.
(completion-pcm--hilit-commonality): Use it.  Add SCORE argument.
(completion--flex-score): Use 'completion--flex-score-1'.  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--return-alist-flag): 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 list completion style results to the new alist format.
(completion-all-completions): Transparently convert the new
alist 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): Fix property removal.

* test/lisp/minibuffer-tests.el:
(completion--test-style)
(completion--test-boundaries): New test helper function.
(completion-emacs22orig-all-completions): New function.
(completion-flex-score-test-*): Add new scoring test functions.
(completion-*-style-test): Add new API tests for each built-in
completion style.
(completion-*-boundaries-test): New boundary tests for each built-in
completion style.
(completion-filter-completions-highlight-test): New API test.
(completion-upgrade-return-type-test): New test of transparent
completion style return value upgrade.
---
 lisp/minibuffer.el            | 580 +++++++++++++++++++++++-----------
 test/lisp/minibuffer-tests.el | 217 ++++++++++++-
 2 files changed, 603 insertions(+), 194 deletions(-)

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 9f327df28f..66ac6b3763 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--return-alist-flag nil
+  "Non-nil means to return completions in alist format.
+If this variable is non-nil the `all-completions' function of a
+completion style should return the results in the alist format of
+`completion-filter-completions'.  This variable is purely needed to
+for backward compatibility of the existing builtin completion style
+functions as of Emacs 28.  Newer completion style functions should
+always return their results in the alist format, since
+`completion-all-completions' transparently converts back to a 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--return-alist-flag nil)
               (setq string (pop new))
               (setq table (pop new))
               (setq point (pop new))
@@ -1069,17 +1093,35 @@ completion--nth-completion
          (result-and-style
           (completion--some
            (lambda (style)
-             (let ((probe (funcall (nth n (assq style
-                                                completion-styles-alist))
-                                   string table pred point)))
+             (let* ((fun (nth n (assq style completion-styles-alist)))
+                    ;; Transparently upgrade the return value for
+                    ;; existing built-in styles as of Emacs 28.  No
+                    ;; new styles should be added here. New completion
+                    ;; styles should directly return the new
+                    ;; completion format.el
+                    (completion--return-alist-flag
+                     (and completion--return-alist-flag
+                          (memq style '(emacs21 emacs22 basic substring
+                                        partial-completion initials flex))))
+                    (probe (funcall fun 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))
+         (result (car result-and-style)))
+    (when (and style-md metadata)
+      (setcdr metadata (cdr (funcall style-md
+                                     string table pred point metadata))))
+    (when (and (not completion--return-alist-flag) (= n 2) (consp (car result)))
+      ;; Give the completion styles some freedom!  If they are
+      ;; targeting Emacs 28 upwards only, they may return a result
+      ;; with deferred highlighting.  We convert back to the old
+      ;; format here by applying the highlighting eagerly.
+      (setq result (nconc (funcall (cdr (assq 'highlight result))
+                                   (cdr (assq 'completions result)))
+                          (cdr (assq 'base result)))))
     (if requote
-        (funcall requote (car result-and-style) n)
-      (car result-and-style))))
+        (funcall requote result n)
+      result)))
 
 (defun completion-try-completion (string table pred point &optional metadata)
   "Try to complete STRING using completion table TABLE.
@@ -1088,7 +1130,8 @@ completion-try-completion
 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."
+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)
@@ -1096,10 +1139,47 @@ completion-all-completions
 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))
+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--return-alist-flag nil))
+    (completion--nth-completion 2 string table pred point metadata)))
+
+(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',
+which does not provide the `end' position of the completion and does
+not support deferred highlighting."
+  (let* ((completion--return-alist-flag 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 alist format of
+        ;; `completion-filter-completions'.
+        (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)
@@ -1115,7 +1195,8 @@ completion--replace
   (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)
+      (remove-text-properties 0 (length newtext)
+                              '(face nil completion-score nil)
                               newtext)
     ;; Remove all text properties.
     (set-text-properties 0 (length newtext) nil newtext))
@@ -2021,34 +2102,49 @@ 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 as a list or as an alist.
+If `completion--return-alist-flag' is non-nil use the alist format of
+`completion-filter-completions'."
+  (if completion--return-alist-flag
+      (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 +2259,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 +2278,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 +2322,12 @@ 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 using the deferred
+                      ;; highlighting function provided by
+                      ;; `completion-format-completions'.
+                      (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 +2366,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 +3319,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 +3346,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 +3410,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 +3602,26 @@ flex-score-match-tightness
 than the latter (which has two \"holes\" and three
 one-letter-long matches).")
 
-(defun completion-pcm--hilit-commonality (pattern completions)
+(defun completion-pcm--deferred-hilit (pattern completions base end)
+  "Return completions as a list or as an alist.
+If `completion--return-alist-flag' is non-nil use the alist format of
+`completion-filter-completions'."
+  (when completions
+    (if completion--return-alist-flag
+        `((base . ,base)
+          (end . ,end)
+          (highlight . ,(apply-partially
+                         #'completion-pcm--hilit-commonality
+                         pattern))
+          (completions . ,completions))
+      (nconc (completion-pcm--hilit-commonality pattern completions 'score) base))))
+
+(defun completion-pcm--hilit-commonality (pattern completions &optional score)
   "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))
@@ -3527,84 +3638,143 @@ completion-pcm--hilit-commonality
                 (match-end (match-end 0))
                 (md (cddr (setq last-md (match-data t last-md))))
                 (from 0)
-                (end (length str))
-                ;; To understand how this works, consider these simple
-                ;; ascii diagrams showing how the pattern "foo"
-                ;; flex-matches "fabrobazo", "fbarbazoo" and
-                ;; "barfoobaz":
-
-                ;;      f abr o baz o
-                ;;      + --- + --- +
-
-                ;;      f barbaz oo
-                ;;      + ------ ++
-
-                ;;      bar foo baz
-                ;;          +++
-
-                ;; "+" indicates parts where the pattern matched.  A
-                ;; "hole" in the middle of the string is indicated by
-                ;; "-".  Note that there are no "holes" near the edges
-                ;; of the string.  The completion score is a number
-                ;; bound by ]0..1]: the higher the better and only a
-                ;; perfect match (pattern equals string) will have
-                ;; score 1.  The formula takes the form of a quotient.
-                ;; For the numerator, we use the number of +, i.e. the
-                ;; length of the pattern.  For the denominator, it
-                ;; first computes
-                ;;
-                ;;     hole_i_contrib = 1 + (Li-1)^(1/tightness)
-                ;;
-                ;; , for each hole "i" of length "Li", where tightness
-                ;; is given by `flex-score-match-tightness'.  The
-                ;; final value for the denominator is then given by:
-                ;;
-                ;;    (SUM_across_i(hole_i_contrib) + 1) * len
-                ;;
-                ;; , 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)
-                   (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))))
+                (len (length str)))
+           (when (and score (/= 0 len))
+             (put-text-property
+              0 1 'completion-score (- (completion--flex-score-1 md match-end len)) str))
            (while md
-             (funcall update-score-and-face from (pop 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)
-             (funcall update-score-and-face from match-end))
-           (if (> (length str) pos)
+             (add-face-text-property from match-end
+                                     'completions-common-part
+                                     nil str))
+           (if (> len 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)))
+                nil str)))
          str)
        completions))))
 
+(defun completion--flex-score-1 (md match-end len)
+  "Compute matching score of completion.
+The score lies in the range between-1 and 0, where -1 corresponds to
+the full match.
+MD is the match data.
+MATCH-END is the end of the match.
+LEN is the length of the completion string."
+  (let* ((from 0)
+         ;; To understand how this works, consider these simple
+         ;; ascii diagrams showing how the pattern "foo"
+         ;; flex-matches "fabrobazo", "fbarbazoo" and
+         ;; "barfoobaz":
+
+         ;;      f abr o baz o
+         ;;      + --- + --- +
+
+         ;;      f barbaz oo
+         ;;      + ------ ++
+
+         ;;      bar foo baz
+         ;;          +++
+
+         ;; "+" indicates parts where the pattern matched.  A
+         ;; "hole" in the middle of the string is indicated by
+         ;; "-".  Note that there are no "holes" near the edges
+         ;; of the string.  The completion score is a number
+         ;; bound by ]0..1]: the higher the better and only a
+         ;; perfect match (pattern equals string) will have
+         ;; score 1.  The formula takes the form of a quotient.
+         ;; For the numerator, we use the number of +, i.e. the
+         ;; length of the pattern.  For the denominator, it
+         ;; first computes
+         ;;
+         ;;     hole_i_contrib = 1 + (Li-1)^(1/tightness)
+         ;;
+         ;; , for each hole "i" of length "Li", where tightness
+         ;; is given by `flex-score-match-tightness'.  The
+         ;; final value for the denominator is then given by:
+         ;;
+         ;;    (SUM_across_i(hole_i_contrib) + 1) * len
+         ;;
+         ;; , where "len" is the string's length.
+         (score-numerator 0)
+         (score-denominator 0)
+         (last-b 0))
+    (while md
+      (let ((a from)
+            (b (pop md)))
+        (setq
+         score-numerator   (+ score-numerator (- b a)))
+        (unless (or (= a last-b)
+                    (zerop last-b)
+                    (= a len))
+          (setq
+           score-denominator (+ score-denominator
+                                1
+                                (expt (- a last-b 1)
+                                      (/ 1.0
+                                         flex-score-match-tightness)))))
+        (setq
+         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)
+      (let ((a from)
+            (b match-end))
+        (setq
+         score-numerator   (+ score-numerator (- b a)))
+        (unless (or (= a last-b)
+                    (zerop last-b)
+                    (= a len))
+          (setq
+           score-denominator (+ score-denominator
+                                1
+                                (expt (- a last-b 1)
+                                      (/ 1.0
+                                         flex-score-match-tightness)))))
+        (setq
+         last-b              b)))
+    (- (/ score-numerator (* len (1+ score-denominator)) 1.0))))
+
+(defun completion--flex-score (pattern completions)
+  "Compute how well PATTERN matches COMPLETIONS.
+PATTERN, a pcm pattern is assumed to match every string in the
+COMPLETIONS list.  Return a copy of COMPLETIONS where each element is
+a pair of a score and the 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'.
+         (let ((unquoted (or (get-text-property 0 'completion--unquoted str) str)))
+           (unless (string-match re unquoted)
+             (error "Internal error: %s does not match %s" re unquoted))
+           (cons (completion--flex-score-1 (cddr (setq last-md (match-data t last-md)))
+                                           (match-end 0) (length unquoted))
+                 str)))
+       completions))))
+
 (defun completion-pcm--find-all-completions (string table pred point
                                                     &optional filter)
   "Find all completions for STRING at POINT in TABLE, satisfying PRED.
@@ -3700,11 +3870,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 +4055,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 +4074,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 +4098,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 +4113,53 @@ 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 ((pre-sorted (if existing-sort-fn
+                                    (funcall existing-sort-fn completions)
+                                  completions)))
+                ;; If `completion-scores' are already present use
+                ;; those instead of recomputing the scores with
+                ;; `completion--flex-score'.  The scores are already
+                ;; present, when the candidates have been computed by
+                ;; `completion-all-completions'.  In contrast, the
+                ;; score is not yet present, when the candidates have
+                ;; been computed by `completion-filter-completions'.
+                (if (and (car pre-sorted)
+                         (get-text-property 0 'completion-score (car pre-sorted)))
+                    (sort
+                     pre-sorted
+                     (lambda (c1 c2)
+                       (> (or (get-text-property 0 'completion-score c1) 0)
+                          (or (get-text-property 0 'completion-score c2) 0))))
+                  (let* ((sorted (sort (completion--flex-score pattern pre-sorted)
+                                       #'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 +4181,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 +4198,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 +4241,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..22de3c9ff5 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -28,8 +28,7 @@
 
 (require 'ert)
 (require 'ert-x)
-
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
 
 (ert-deftest completion-test1 ()
   (with-temp-buffer
@@ -331,5 +330,219 @@ 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 "X")))))
+
+(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))
+    ;; The highlighting function should be present.
+    (should (not (memq (alist-get 'highlight result) '(nil identity))))
+    ;; Equal results as `completion-all-completions'.
+    (should (equal (completion-all-completions string table pred point)
+                   (append filtered 0)))
+    ;; The returned strings should be identical to the original strings.
+    ;; The `completion-filter-completions' function avoids allocations!
+    (should (cl-intersection (alist-get 'completions result)
+                             table :test #'eq))))
+
+(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 list completion style return value
+  ;; to the alist return value format of `completion-format-completions'.
+  (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