From 78057f40e53f39f0b26f4b9bf5d950b72f1c3d99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jo=C3=A3o=20T=C3=A1vora?= Date: Wed, 25 Oct 2023 13:45:01 +0100 Subject: [PATCH] Allow completion frontends to highlight completion strings just-in-time This allows completion-pcm--hilit-commonality to be sped up substantially. Introduce a new variable completion-lazy-hilit that allows for completion frontends to opt-in an time-saving optimization by some completions styles, such as the 'flex' and 'pcm' styles. The variable must be bound or set by the frontend to a unique value around a completion attempt/session. See completion-lazy-hilit docstring for more info. * lisp/icomplete.el (icomplete-minibuffer-setup): Set completion-lazy-hilit. (icomplete--render-vertical): Call completion-lazy-hilit. (icomplete-completions): Call completion-lazy-hilit. * lisp/minibuffer.el (completion-lazy-hilit): New variable. (completion-lazy-hilit) (completion--hilit-from-re): New functions. (completion--lazy-hilit-table): New variable. (completion--flex-score-1): New helper. (completion-pcm--hilit-commonality): Use completion-lazy-hilit. --- lisp/icomplete.el | 9 +- lisp/minibuffer.el | 262 +++++++++++++++++++++++++++++---------------- 2 files changed, 173 insertions(+), 98 deletions(-) diff --git a/lisp/icomplete.el b/lisp/icomplete.el index e6fdd1f1836..a9ac0b3f040 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -545,6 +545,7 @@ icomplete-minibuffer-setup (setq-local icomplete--initial-input (icomplete--field-string)) (setq-local completion-show-inline-help nil) (setq icomplete--scrolled-completions nil) + (setq completion-lazy-hilit (cl-gensym)) (use-local-map (make-composed-keymap icomplete-minibuffer-map (current-local-map))) (add-hook 'post-command-hook #'icomplete-post-command-hook nil t) @@ -754,12 +755,13 @@ icomplete-exhibit (overlay-end rfn-eshadow-overlay))) (let* ((field-string (icomplete--field-string)) (text (while-no-input + (benchmark-progn (icomplete-completions field-string (icomplete--completion-table) (icomplete--completion-predicate) (if (window-minibuffer-p) - (eq minibuffer--require-match t))))) + (eq minibuffer--require-match t)))))) (buffer-undo-list t) deactivate-mark) ;; Do nothing if while-no-input was aborted. @@ -901,7 +903,7 @@ icomplete--render-vertical 'icomplete-selected-match 'append comp) collect (concat prefix (make-string (- max-prefix-len (length prefix)) ? ) - comp + (completion-lazy-hilit comp) (make-string (- max-comp-len (length comp)) ? ) suffix) into lines-aux @@ -1067,7 +1069,8 @@ icomplete-completions (if (< prospects-len prospects-max) (push comp prospects) (setq limit t))) - (setq prospects (nreverse prospects)) + (setq prospects + (nreverse (mapcar #'completion-lazy-hilit prospects))) ;; Decorate first of the prospects. (when prospects (let ((first (copy-sequence (pop prospects)))) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 2120e31775e..4591f1145c8 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -3749,108 +3749,180 @@ flex-score-match-tightness than the latter (which has two \"holes\" and three one-letter-long matches).") +(defvar-local completion-lazy-hilit nil + "If non-nil, request completion lazy hilighting. + +Completion-presenting frontends may opt to bind this variable to +a unique non-nil value in the context of completion-producing +calls (such as `completion-all-sorted-completions'). This hints +the intervening completion styles that they do not need to +propertize completion strings with the `face' property. + +When doing so, it is the frontend -- not the style -- who becomes +responsible for `face'-propertizing only the completion strings +that are meant to be displayed to the user. This can be done by +calling the function `completion-lazy-hilit' which returns a +`face'-propertized string. + +The value stored in this variable by the completion frontend +should be unique to each completion attempt or session that +utilizes the same completion style in `completion-styles-alist'. +For frontends using the minibuffer as the locus of completion +calls and display, setting it to a buffer-local value given by +`gensym' is appropriate. For frontends operating entirely in a +single command, let-binding it to `gensym' is appropriate. + +Note that the optimization enabled by variable is only actually +performed some completions styles. To others, it is a harmless +and useless hint. To author a completion style that takes +advantage of this, look in the source of +`completion-pcm--hilit-commonality'.") + +(defun completion-lazy-hilit (str) + "Return a copy of completion STR that is `face'-propertized. +See documentation for variable `completion-lazy-hilit' for more +details." + (completion--hilit-from-re + (copy-sequence str) + (gethash completion-lazy-hilit completion--lazy-hilit-table))) + +(defun completion--hilit-from-re (string regexp) + "Fontify STRING with `completions-common-part' using REGEXP." + (let* ((md (and regexp (string-match regexp string) (cddr (match-data t)))) + (me (and md (match-end 0))) + (from 0)) + (while md + (add-face-text-property from (pop md) 'completions-common-part nil string) + (setq from (pop md))) + (unless (or (not me) (= from me)) + (add-face-text-property from me 'completions-common-part nil string)) + string)) + +(defun completion--flex-score-1 (md match-end len) + "Compute matching score of completion. +The score lies in the range between 0 and 1, 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] (i.e., larger than (but not equal + ;; to) zero, and smaller or equal to one): 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))) + +(defvar completion--lazy-hilit-table (make-hash-table :weakness 'key)) + (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." +string in COMPLETIONS. + +If `completion-lazy-hilit' is nil, 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. + +Else, if `completion-lazy-hilit' is t, return COMPLETIONS where +each string now has a `completion-score' property and no +highlighting." (cond ((and completions (cl-loop for e in pattern thereis (stringp e))) (let* ((re (completion-pcm--pattern->regex pattern 'group)) - (point-idx (completion-pcm--pattern-point-idx pattern)) - (case-fold-search completion-ignore-case) - last-md) - (mapcar - (lambda (str) - ;; 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))) - (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] (i.e., larger than (but not equal - ;; to) zero, and smaller or equal to one): 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)))) - (while md - (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) - '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) - completions))) + last-md + (score (lambda (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))))) + (completion--flex-score-1 md match-end (length str)))))) + (cond (completion-lazy-hilit + (puthash completion-lazy-hilit re completion--lazy-hilit-table) + (mapc (lambda (str) + (put-text-property 0 1 'completion-score (funcall score str) str)) + completions)) + (t + (mapcar + (lambda (str) + (setq str (copy-sequence str)) + (put-text-property 0 1 'completion-score (funcall score str) str) + (completion--hilit-from-re str re) + str) + completions))))) (t completions))) (defun completion-pcm--find-all-completions (string table pred point -- 2.39.2