master d199a46: Robustify completion match scoring for optimized patterns

[João Távora]

branch: master
commit d199a4640f53673a3bba79ab82cf819009e65e8f
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    Robustify completion match scoring for optimized patterns
    
    Fixes: bug#42149
    
    The function completion-pcm--hilit-commonality, which propertizes and
    scores a previously confirmed match, expected its PATTERN argument to
    match the strings of COMPLETIONS entirely (i.e. up to the string's
    very end).  But sometimes the ending wildcard, represented by the
    'any' atom in PATTERN, is optimized away by
    completion-pcm--optimize-pattern.  Although this is mostly benign in
    terms of highlighting commonality, it leads to incorrect score values.
    
    In this change, we ensure that completion-pcm--hilit-commonality is
    aware of this exception and isn't affected by it.  We also document
    the function a bit better and simplify its workings.
    
    Originally reported by Dario Gjorgjevski <dario.gjorgjevski@gmail.com>
    
    * lisp/minibuffer.el (completion-pcm--hilit-commonality):
    Simplify.  Add docstring.
    
    * lisp/minibuffer.el (completion-pcm--hilit-commonality): Add
    docstring
---
 lisp/minibuffer.el | 48 +++++++++++++++++++++++++++---------------------
 1 file changed, 27 insertions(+), 21 deletions(-)

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index c8c106c..dc37c5f 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -3245,6 +3245,13 @@ than the latter (which has two \"holes\" and three
 one-letter-long matches).")
 
 (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',
+`completions-first-difference' in the relevant segments."
   (when completions
     (let* ((re (completion-pcm--pattern->regex pattern 'group))
            (point-idx (completion-pcm--pattern-point-idx pattern))
@@ -3256,12 +3263,12 @@ one-letter-long matches).")
          (unless (string-match re str)
            (error "Internal error: %s does not match %s" re str))
          (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
-                (md (match-data))
-                (start (pop md))
-                (end (pop md))
-                (len (length str))
-                ;; To understand how this works, consider these bad
-                ;; ascii(tm) diagrams showing how the pattern "foo"
+                (match-end (match-end 0))
+                (md (cddr (match-data)))
+                (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":
 
@@ -3297,9 +3304,12 @@ one-letter-long matches).")
                 (score-numerator 0)
                 (score-denominator 0)
                 (last-b 0)
-                (update-score
+                (update-score-and-face
                  (lambda (a b)
-                   "Update score variables given match range (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)
@@ -3313,19 +3323,15 @@ one-letter-long matches).")
                                                     
flex-score-match-tightness)))))
                    (setq
                     last-b              b))))
-           (funcall update-score start start)
            (while md
-             (funcall update-score start (car md))
-             (add-face-text-property
-              start (pop md)
-              'completions-common-part
-              nil str)
-             (setq start (pop md)))
-           (funcall update-score len len)
-           (add-face-text-property
-            start end
-            'completions-common-part
-            nil str)
+             (funcall update-score-and-face from (pop md))
+             (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)
@@ -3334,7 +3340,7 @@ one-letter-long matches).")
            (unless (zerop (length str))
              (put-text-property
               0 1 'completion-score
-              (/ score-numerator (* len (1+ score-denominator)) 1.0) str)))
+              (/ score-numerator (* end (1+ score-denominator)) 1.0) str)))
          str)
        completions))))