Package: emacs;
Reported by: Daniel Mendler <mail <at> daniel-mendler.de>
Date: Sun, 11 Apr 2021 20:52:01 UTC
Severity: normal
Found in version 27.1
Done: Daniel Mendler <mail <at> daniel-mendler.de>
Bug is archived. No further changes may be made.
Message #278 received at 47711 <at> debbugs.gnu.org (full text, mbox):
From: João Távora <joaotavora <at> gmail.com> To: Dmitry Gutov <dmitry <at> gutov.dev> Cc: Daniel Mendler <mail <at> daniel-mendler.de>, Eli Zaretskii <eliz <at> gnu.org>, Stefan Monnier <monnier <at> iro.umontreal.ca>, 47711 <at> debbugs.gnu.org Subject: Re: bug#48841: bug#47711: bug#48841: bug#47711: [PATCH VERSION 2] Add new `completion-filter-completions` API and deferred highlighting Date: Fri, 27 Oct 2023 00:27:12 +0100
[Message part 1 (text/plain, inline)]
Dmitry Gutov <dmitry <at> gutov.dev> writes: > My understanding is it's due to the judicious call (copy-sequence > orig) that you added before 'put-text-property' is called. While it > seems like a good idea to preserve the original value, when almost all > of obarray matches the current input (which is the current scenario), > a lot of strings will be copied. You're right, I reproduced the regression. I thought I had taken out the copy-sequence, but forgot it there. In an earlier stage I suspected that I needed the copy, but I don't think I do. Please try this new patch that removes it. I've also pushed it to the feature/completion-lazy-hilit branch. João
[lazy-hilit-2023-v3.diff (text/x-patch, inline)]
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index e6fdd1f1836..3e888c8b06a 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -722,7 +722,8 @@ icomplete-exhibit
;; 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:
@@ -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..ecde00dd28d 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -1234,6 +1234,7 @@ completion-all-completions
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))
@@ -3720,21 +3721,32 @@ completion-pcm--all-completions
;; Use all-completions to do an initial cull. This is a big win,
;; since all-completions is written in C!
- (let* (;; Convert search pattern to a standard regular expression.
- (regex (completion-pcm--pattern->regex pattern))
- (case-fold-search completion-ignore-case)
- (completion-regexp-list (cons regex completion-regexp-list))
- (compl (all-completions
- (concat prefix
- (if (stringp (car pattern)) (car pattern) ""))
- table pred)))
- (if (not (functionp table))
- ;; The internal functions already obeyed completion-regexp-list.
- compl
- (let ((poss ()))
- (dolist (c compl)
- (when (string-match-p regex c) (push c poss)))
- (nreverse poss))))))
+ (let* ((case-fold-search completion-ignore-case)
+ (completion-regexp-list (cons
+ ;; Convert search pattern to a
+ ;; standard regular expression.
+ (completion-pcm--pattern->regex pattern)
+ completion-regexp-list))
+ (completions (all-completions
+ (concat prefix
+ (if (stringp (car pattern)) (car pattern) ""))
+ table pred)))
+ (cond ((or (not (functionp table))
+ (cl-loop for e in pattern never (stringp e)))
+ ;; The internal functions already obeyed completion-regexp-list.
+ completions)
+ (t
+ ;; The pattern has something interesting to match, in
+ ;; which case we take the opportunity to add an early
+ ;; completion-score cookie to each completion.
+ (cl-loop with re = (completion-pcm--pattern->regex pattern 'group)
+ for comp in completions
+ for score = (completion--flex-score comp re t)
+ when score
+ do (put-text-property 0 1 'completion-score
+ score
+ comp)
+ and collect comp))))))
(defvar flex-score-match-tightness 3
"Controls how the `flex' completion style scores its matches.
@@ -3749,108 +3761,195 @@ 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 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-sorted-completions'). This hints the
+intervening completion styles that they do not need to
+fontify (i.e. propertize with the `face' property) completion
+strings with highlights of the matching parts.
+
+When doing so, it is the frontend -- not the style -- who becomes
+responsible 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 greedily fontify 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
+ "Used by completions styles to honouring `completion-lazy-hilit'.
+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 highlighting the string.")
+
+(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))))
+
(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)))
+ (score-maybe (lambda (str)
+ (unless (get-text-property 0 'completion-score str)
+ (put-text-property 0 1 'completion-score
+ (completion--flex-score str re)
+ str)))))
+ (cond (completion-lazy-hilit
+ (setq completion-lazy-hilit-fn
+ (lambda (str) (completion--hilit-from-re str re)))
+ (mapc score-maybe completions))
+ (t
+ (mapcar
+ (lambda (str)
+ (setq str (copy-sequence str))
+ (funcall score-maybe str)
+ (completion--hilit-from-re str re)
+ str)
+ completions)))))
(t completions)))
(defun completion-pcm--find-all-completions (string table pred point
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.