scratch/icomplete-lazy-highlight-attempt-2 70e5147: Allow completion frontends to highlight completion strings just in time

[João Távora]

branch: scratch/icomplete-lazy-highlight-attempt-2
commit 70e51476552f5d178c08463e34ca02f5485effff
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    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 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): New function.
    (completion-pcm--hilit-commonality): Use completion-lazy-hilit.
---
 lisp/icomplete.el  | 10 +++++---
 lisp/minibuffer.el | 67 +++++++++++++++++++++++++++++++++++++++++++++++-------
 2 files changed, 66 insertions(+), 11 deletions(-)

diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index adea150..21cf753 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -491,6 +491,7 @@ Usually run by inclusion in `minibuffer-setup-hook'."
     (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)
@@ -797,7 +798,9 @@ Return a list of (COMP PREFIX SUFFIX)."
                (cl-return-from icomplete--render-vertical
                  (concat
                   " \n"
-                  (mapconcat #'identity torender icomplete-separator))))
+                  (mapconcat #'identity
+                             (mapcar #'completion-lazy-hilit torender)
+                             icomplete-separator))))
    for (comp prefix) in triplets
    maximizing (length prefix) into max-prefix-len
    maximizing (length comp) into max-comp-len
@@ -809,7 +812,7 @@ Return a list of (COMP PREFIX SUFFIX)."
     (cl-loop for (comp prefix suffix) in triplets
              concat prefix
              concat (make-string (- max-prefix-len (length prefix)) ? )
-             concat comp
+             concat (completion-lazy-hilit comp)
              concat (make-string (- max-comp-len (length comp)) ? )
              concat suffix
              concat icomplete-separator))))
@@ -959,7 +962,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 1e8e9fc..f460e9c 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -3512,6 +3512,51 @@ 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 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
+requests to the intervening completion styles do not eagerly
+propertize completion strings with the `face' property.
+
+The value stored in this valuable should be unique to each
+completion attempt or session that utilizes the same completion
+style in `completion-styles-alist'.
+
+When doing so, the frontend, not the style, becomes responsible
+for `face'-propertizing the completion strings that it wishes to
+display to the user, which can be done by calling the function
+`completion-lazy-hilit' just in time.  The function returns a
+`face'-propertized string to display to the user.
+
+This variable is only actually useful by some completions styles,
+which may perform important time-saving optimizations. To author
+a completion style that takes advantage of this, look for example
+in the source of `completion-pcm--hilit-commonality'.")
+
+(defun completion-lazy-hilit (str)
+  "Return a copy of completion STR that is `face'-propertized.
+TOKEN is the unique value of `completion-lazy-hilit' that the
+completion-presenting frontend calling this function has
+previously used.  See documentation for variable
+`completion-lazy-hilit' for more details."
+  (let* ((str (copy-sequence str))
+         (data (get-text-property 0 'completion-lazy-hilit-data str))
+         (re (and
+              completion-lazy-hilit
+              (eq completion-lazy-hilit (car data)) (cdr data)))
+         (md (and re (string-match re str) (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 str)
+      (setq from (pop md)))
+    (unless (or (not me) (= from me))
+      (add-face-text-property from me 'completions-common-part nil str))
+    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
@@ -3524,17 +3569,18 @@ between 0 and 1, and with faces 
`completions-common-part',
     (let* ((re (completion-pcm--pattern->regex pattern 'group))
            (point-idx (completion-pcm--pattern-point-idx pattern))
            (case-fold-search completion-ignore-case)
+           (from 0)
            last-md)
       (mapcar
        (lambda (str)
-        ;; Don't modify the string itself.
-         (setq str (copy-sequence str))
+         (unless completion-lazy-hilit
+           ;; 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"
@@ -3576,9 +3622,10 @@ between 0 and 1, and with faces 
`completions-common-part',
                 (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)
+                   (unless completion-lazy-hilit
+                     (add-face-text-property a b
+                                             'completions-common-part
+                                             nil str))
                    (setq
                     score-numerator   (+ score-numerator (- b a)))
                    (unless (or (= a last-b)
@@ -3601,11 +3648,15 @@ between 0 and 1, and with faces 
`completions-common-part',
            ;; for that extra bit of match (bug#42149).
            (unless (= from match-end)
              (funcall update-score-and-face from match-end))
-           (if (> (length str) pos)
+           (put-text-property 0 1 'completion-lazy-hilit-data
+                              (cons completion-lazy-hilit re) str)
+           (if (and (> (length str) pos)
+                    (not completion-lazy-hilit))
                (add-face-text-property
                 pos (1+ pos)
                 'completions-first-difference
-                nil str))
+                nil str)
+             )
            (unless (zerop (length str))
              (put-text-property
               0 1 'completion-score