From: João Távora Date: Wed, 25 Oct 2023 12:45:01 +0000 (+0100) Subject: Allow completion frontends to fontify candidates just-in-time X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=dfffb91a70532ac0021648ba692336331cbe0499;p=emacs.git Allow completion frontends to fontify candidates just-in-time bug#48841, bug#47711 The variable may be bound by the frontend to a non-nil around completion-producing calls like completion-all-completions. 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): New function. (completion-lazy-hilit-fn): New variable. (completion-pcm--regexp) (completion--flex-score-last-md): New helper variables. (completion--flex-score-1): New helper. (completion-pcm--hilit-commonality): Use completion-lazy-hilit. (completion--flex-adjust-metadata): Rework sorting code. * etc/NEWS: Mention completion-lazy-hilit --- diff --git a/etc/NEWS b/etc/NEWS index 94bcb75835b..b9a1c3dd572 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1279,6 +1279,13 @@ with Emacs. If non-nil, this variable contains a keymap of menu items that are displayed along tool bar items inside 'tool-bar-map'. +** New variable 'completion-lazy-hilit'. +Completion-presenting frontends may bind this variable non-nil around +calls to functions such as `completion-all-completions'. This hints +at the underlying completion styles to skip eager fontification of +completion candidates, which increases performance. Frontends then +use the 'completion-lazy-hilit' function to fontify just in time. + ** Functions and variables to transpose sexps +++ diff --git a/lisp/icomplete.el b/lisp/icomplete.el index e6fdd1f1836..f4c4feb7304 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -722,7 +722,8 @@ See `icomplete-mode' and `minibuffer-setup-hook'." ;; Check if still in the right buffer (bug#61308) (or (window-minibuffer-p) completion-in-region--data) (icomplete-simple-completing-p)) ;Shouldn't be necessary. - (let ((saved-point (point))) + (let ((saved-point (point)) + (completion-lazy-hilit t)) (save-excursion (goto-char (icomplete--field-end)) ;; Insert the match-status information: @@ -901,7 +902,7 @@ by `group-function''s second \"transformation\" protocol." '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 +1068,8 @@ matches exist." (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 45d9a113d0b..ca2b25415f1 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -677,6 +677,10 @@ for use at QPOS." '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 @@ -1234,6 +1238,7 @@ 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'." + (setq completion-lazy-hilit-fn nil) ;; 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)) @@ -3793,108 +3798,193 @@ one large \"hole\" and a clumped-together \"oo\" match) higher than the latter (which has two \"holes\" and three one-letter-long matches).") +(defvar completion-lazy-hilit nil + "If non-nil, request completion lazy highlighting. + +Completion-presenting frontends may opt to bind this variable to +non-nil value in the context of completion-producing calls (such +as `completion-all-completions'). This hints the intervening +completion styles that they do not need to +fontify (i.e. propertize with a `face' property) completion +strings with highlights of the matching parts. + +When doing so, it is the frontend -- not the style -- who becomes +responsible for this fontification. The frontend binds this +variable to non-nil, and calls the function with the same name +`completion-lazy-hilit' on each completion string that is to be +displayed to the user. + +Note that only some completion styles take advantage of this +variable for optimization purposes. Other styles will ignore the +hint and fontify eagerly as usual. It is still safe for a +frontend to call `completion-lazy-hilit' in these situations. + +To author a completion style that takes advantage see +`completion-lazy-hilit-fn' and look in the source of +`completion-pcm--hilit-commonality'.") + +(defvar completion-lazy-hilit-fn nil + "Function set by lazy-highlighting completions styles. +When a given style wants to enable support for +`completion-lazy-hilit' (which see), that style should set this +variable to a function of one argument, a fresh string to be +displayed to the user. The function is responsible for +destructively propertizing the string with a `face' property.") + +(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." + (if (and completion-lazy-hilit completion-lazy-hilit-fn) + (funcall completion-lazy-hilit-fn (copy-sequence str)) + str)) + +(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-groups 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-GROUPS is the \"group\" part of 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 (and md-groups (car md-groups)) + (let ((a from) + (b (pop md-groups))) + (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-groups))) + ;; 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--flex-score-last-md nil + "Helper variable for `completion--flex-score'.") + +(defun completion--flex-score (str re &optional dont-error) + "Compute flex score of completion STR based on RE. +If DONT-ERROR, just return nil if RE doesn't match STR." + (cond ((string-match re str) + (let* ((match-end (match-end 0)) + (md (cddr + (setq + completion--flex-score-last-md + (match-data t completion--flex-score-last-md))))) + (completion--flex-score-1 md match-end (length str)))) + ((not dont-error) + (error "Internal error: %s does not match %s" re str)))) + +(defvar completion-pcm--regexp nil + "Regexp from PCM pattern in `completion-pcm--hilit-commonality'.") + (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 +unchanged, but setup a suitable `completion-lazy-hilit-fn' (which +see) for later lazy highlighting." + (setq completion-pcm--regexp nil + completion-lazy-hilit-fn nil) (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))) + (let* ((re (completion-pcm--pattern->regex pattern 'group))) + (setq completion-pcm--regexp re) + (cond (completion-lazy-hilit + (setq completion-lazy-hilit-fn + (lambda (str) (completion--hilit-from-re str re))) + completions) + (t + (mapcar + (lambda (str) + (completion--hilit-from-re (copy-sequence str) re)) + completions))))) (t completions))) (defun completion-pcm--find-all-completions (string table pred point @@ -4231,36 +4321,39 @@ that is non-nil." (defun completion--flex-adjust-metadata (metadata) "If `flex' is actually doing filtering, adjust sorting." - (let ((flex-is-filtering-p - ;; JT@2019-12-23: FIXME: this is kinda wrong. What we need - ;; to test here is "some input that actually leads/led to - ;; flex filtering", not "something after the minibuffer - ;; prompt". E.g. The latter is always true for file - ;; searches, meaning we'll be doing extra work when we - ;; needn't. - (or (not (window-minibuffer-p)) - (> (point-max) (minibuffer-prompt-end)))) + (let ((flex-is-filtering-p completion-pcm--regexp) (existing-dsf (completion-metadata-get metadata 'display-sort-function)) (existing-csf (completion-metadata-get metadata 'cycle-sort-function))) (cl-flet - ((compose-flex-sort-fn - (existing-sort-fn) ; wish `cl-flet' had proper indentation... - (lambda (completions) - (sort - (funcall existing-sort-fn completions) - (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)))))))) + ((compose-flex-sort-fn (existing-sort-fn) + (lambda (completions) + (let* ((sorted (sort + (mapcar + (lambda (str) + (cons + (- (completion--flex-score + (or (get-text-property + 0 'completion--unquoted str) + str) + completion-pcm--regexp)) + str)) + (if existing-sort-fn + (funcall existing-sort-fn completions) + completions)) + #'car-less-than-car)) + (cell sorted)) + ;; Reuse the list + (while cell + (setcar cell (cdar cell)) + (pop cell)) + sorted)))) `(metadata ,@(and flex-is-filtering-p - `((display-sort-function - . ,(compose-flex-sort-fn (or existing-dsf #'identity))))) + `((display-sort-function . ,(compose-flex-sort-fn existing-dsf)))) ,@(and flex-is-filtering-p - `((cycle-sort-function - . ,(compose-flex-sort-fn (or existing-csf #'identity))))) + `((cycle-sort-function . ,(compose-flex-sort-fn existing-csf)))) ,@(cdr metadata))))) (defun completion-flex--make-flex-pattern (pattern)