From 59c4b64e830bef4258dba06e77e674f33b603918 Mon Sep 17 00:00:00 2001 From: Dario Gjorgjevski Date: Wed, 14 Oct 2020 10:06:40 +0200 Subject: [PATCH] Fix PCM scoring ignoring last part of query string MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This issue is especially evident for single-character query strings, e.g., (completion-flex-all-completions "1" '("1" "foo1") nil 1) would match both "1" and "foo1" with a completion score of 0, whereas they should have completion scores of 1 and 0.25 respectively. See also bug#42149. Furthermore, ‘completions-first-difference’ and ‘completions-common-part’ would sometimes overlap depending on the position of point within the query string. The former is fixed by correcting the part of ‘completion-pcm--hilit-commonality’ responsible for looping over the holes in the query string. The latter is fixed by explicitly moving the position of ‘completions-first-difference’ in case an overlap with ‘completions-common-part’ is detected. * lisp/minibuffer.el (completion-pcm--hilit-commonality): Correctly loop over the holes in the query string; detect overlaps of ‘completions-first-difference’ with ‘completions-common-part’; pre-compute the numerator. (completion-pcm--optimize-pattern): Turn multiple consecutive occurrences of ‘any’ into just a single one. (completion-pcm--count-leading-holes): New function. (completion-pcm--match-size): New function. * test/lisp/minibuffer-tests.el (completion-pcm-all-completions-test, completion-substring-all-completions-test, completion-flex-all-completions-test): Regression tests. --- lisp/minibuffer.el | 99 +++++++++++++++----------- test/lisp/minibuffer-tests.el | 127 ++++++++++++++++++++++++++++++++++ 2 files changed, 184 insertions(+), 42 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 427636e866..38bb4d0785 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -3110,6 +3110,7 @@ or a symbol, see `completion-pcm--merge-completions'." (while p (pcase p (`(,(or 'any 'any-delim) point . ,rest) (setq p `(point . ,rest))) + (`(any any . ,rest) (setq p `(any . ,rest))) ;; This is not just a performance improvement: it turns a ;; terminating `point' into an implicit `any', which affects ;; the final position of point (because `point' gets turned @@ -3193,21 +3194,32 @@ one large \"hole\" and a clumped-together \"oo\" match) higher than the latter (which has two \"holes\" and three one-letter-long matches).") +(defun completion-pcm--count-leading-holes (pattern) + "Count the number of leading holes in PATTERN." + (length (seq-take-while #'symbolp pattern))) + +(defun completion-pcm--match-size (pattern) + "Return the match size of PATTERN." + (apply #'+ + (mapcar + (lambda (part) (if (stringp part) (length part) 0)) + pattern))) + (defun completion-pcm--hilit-commonality (pattern completions) (when completions (let* ((re (completion-pcm--pattern->regex pattern 'group)) (point-idx (completion-pcm--pattern-point-idx pattern)) - (case-fold-search completion-ignore-case)) + (case-fold-search completion-ignore-case) + (num-leading-holes (completion-pcm--count-leading-holes pattern)) + (score-numerator (float (completion-pcm--match-size pattern)))) (mapcar (lambda (str) - ;; Don't modify the string itself. + ;; Don't modify the string itself. (setq str (copy-sequence str)) (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" @@ -3243,47 +3255,50 @@ one-letter-long matches).") ;; (SUM_across_i(hole_i_contrib) + 1) * len ;; ;; , where "len" is the string's length. - (score-numerator 0) + (full-match-start (pop md)) + (full-match-end (pop md)) + (match-start) (score-denominator 0) - (last-b 0) - (update-score - (lambda (a b) - "Update score variables given match range (A B)." - (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)))) - (funcall update-score start start) + (hilit (lambda (match-start match-end) + (add-face-text-property + match-start match-end + 'completions-common-part + nil str) + ;; Maybe move `pos' away so we don not end up + ;; putting `completions-first-difference' over + ;; text that actually matches. + (when (and (>= pos match-start) (< pos match-end)) + (setq pos match-end))))) + ;; Make sure that leading holes are explicitly discarded. + ;; Trailing holes are taken care of by + ;; `completion-pcm--optimize-pattern'. + (if (zerop num-leading-holes) + (setq match-start full-match-start) + (dotimes (_ (1- (* 2 num-leading-holes))) + (pop md)) + (setq match-start (pop md))) (while md - (funcall update-score start (car md)) + (let ((hole-start (pop md)) + (hole-end (pop md))) + (funcall hilit match-start hole-start) + (unless (= hole-start hole-end) + (setq + score-denominator (+ score-denominator + 1 + (expt + (- hole-end hole-start 1) + (/ 1.0 flex-score-match-tightness))))) + (setq match-start hole-end))) + (funcall hilit match-start full-match-end) + (when (> len pos) (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) - (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 (* len (1+ score-denominator)) 1.0) str))) + pos (1+ pos) + 'completions-first-difference + nil str)) + (put-text-property + 0 1 + 'completion-score + (/ score-numerator (* len (1+ score-denominator))) str)) str) completions)))) diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index 5da86f3614..a473fec441 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -104,5 +104,132 @@ nil (length input)) (cons output (length output))))))) +(ert-deftest completion-pcm-all-completions-test () + ;; Point is at end, this does not match anything + (should (equal + (completion-pcm-all-completions + "foo" '("hello" "world" "barfoobar") nil 3) + nil)) + ;; Point is at beginning, this matches "barfoobar" + (should (equal + (car (completion-pcm-all-completions + "foo" '("hello" "world" "barfoobar") nil 0)) + "barfoobar")) + ;; Full match! + (should (eql + (get-text-property + 0 'completion-score + (car (completion-pcm-all-completions + "R" '("R" "hello") nil 1))) + 1.0)) + ;; One fourth of a match and no match due to point being at the end + (should (eql + (get-text-property + 0 'completion-score + (car (completion-pcm-all-completions + "RO" '("RaOb") nil 1))) + (/ 1.0 4.0))) + (should (equal + (completion-pcm-all-completions + "RO" '("RaOb") nil 2) + nil)) + ;; Point is at beginning, but `completions-first-difference' is + ;; moved after it + (should (equal + (get-text-property + 1 'face + (car (completion-pcm-all-completions + "f" '("few" "many") nil 0))) + 'completions-first-difference)) + ;; Wildcards and delimiters work + (should (equal + (car (completion-pcm-all-completions + "li-pac*" '("list-packages") nil 7)) + "list-packages")) + (should (equal + (car (completion-pcm-all-completions + "li-pac*" '("do-not-list-packages") nil 7)) + nil))) + +(ert-deftest completion-substring-all-completions-test () + ;; One third of a match! + (should (equal + (car (completion-substring-all-completions + "foo" '("hello" "world" "barfoobar") nil 3)) + "barfoobar")) + (should (eql + (get-text-property + 0 'completion-score + (car (completion-substring-all-completions + "foo" '("hello" "world" "barfoobar") nil 3))) + (/ 1.0 3.0))) + ;; Full match! + (should (eql + (get-text-property + 0 'completion-score + (car (completion-substring-all-completions + "R" '("R" "hello") nil 1))) + 1.0)) + ;; Substring match + (should (equal + (car (completion-substring-all-completions + "custgroup" '("customize-group") nil 4)) + "customize-group")) + (should (equal + (car (completion-substring-all-completions + "custgroup" '("customize-group") nil 5)) + nil)) + ;; `completions-first-difference' should be at the right place + (should (equal + (get-text-property + 4 'face + (car (completion-substring-all-completions + "jab" '("dabjobstabby" "many") nil 1))) + 'completions-first-difference)) + (should (equal + (get-text-property + 6 'face + (car (completion-substring-all-completions + "jab" '("dabjabstabby" "many") nil 1))) + 'completions-first-difference)) + (should (equal + (get-text-property + 6 'face + (car (completion-substring-all-completions + "jab" '("dabjabstabby" "many") nil 3))) + 'completions-first-difference))) + +(ert-deftest completion-flex-all-completions-test () + ;; Fuzzy match + (should (equal + (car (completion-flex-all-completions + "foo" '("hello" "world" "fabrobazo") nil 3)) + "fabrobazo")) + ;; Full match! + (should (eql + (get-text-property + 0 'completion-score + (car (completion-flex-all-completions + "R" '("R" "hello") nil 1))) + 1.0)) + ;; Another fuzzy match, but more of a "substring" one + (should (equal + (car (completion-flex-all-completions + "custgroup" '("customize-group-other-window") nil 4)) + "customize-group-other-window")) + ;; `completions-first-difference' should be at the right place + (should (equal + (get-text-property + 4 'face + (car (completion-flex-all-completions + "custgroup" '("customize-group-other-window") nil 4))) + 'completions-first-difference)) + (should (equal + (get-text-property + 15 'face + (car (completion-flex-all-completions + "custgroup" '("customize-group-other-window") nil 9))) + 'completions-first-difference))) + (provide 'completion-tests) ;;; completion-tests.el ends here -- 2.17.1