master 3c3c46f4298 1/2: ; Improve and add tests for Completion Preview mode

[Eli Zaretskii]

branch: master
commit 3c3c46f4298fca9349fab080d974bdf7cdc7c25a
Author: Eshel Yaron <me@eshelyaron.com>
Commit: Eli Zaretskii <eliz@gnu.org>

    ; Improve and add tests for Completion Preview mode
    
    Fix handling of capfs that return a function or signal an error,
    respect the ':exclusive' completion property, fix lingering "exact"
    face after deletion that makes the matches non-exact, and add tests.
    
    * lisp/completion-preview.el (completion-preview--make-overlay): Only
    reuse the previous 'after-string' if it has the right face.
    (completion-preview--try-table)
    (completion-preview--capf-wrapper): New functions.
    (completion-preview--update): Use them.
    * test/lisp/completion-preview-tests.el: New file.  (Bug#67275)
---
 lisp/completion-preview.el            | 107 ++++++++++++--------
 test/lisp/completion-preview-tests.el | 184 ++++++++++++++++++++++++++++++++++
 2 files changed, 250 insertions(+), 41 deletions(-)

diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 6048d5be272..95410e2e5cd 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -155,7 +155,9 @@ first candidate, and you can cycle between the candidates 
with
     (setq completion-preview--overlay (make-overlay pos pos))
     (overlay-put completion-preview--overlay 'window (selected-window)))
   (let ((previous (overlay-get completion-preview--overlay 'after-string)))
-    (unless (and previous (string= previous string))
+    (unless (and previous (string= previous string)
+                 (eq (get-text-property 0 'face previous)
+                     (get-text-property 0 'face string)))
       (add-text-properties 0 1 '(cursor 1) string)
       (overlay-put completion-preview--overlay 'after-string string))
     completion-preview--overlay))
@@ -178,48 +180,71 @@ first candidate, and you can cycle between the candidates 
with
     (completion-preview-active-mode -1)
     (when (functionp func) (apply func args))))
 
+(defun completion-preview--try-table (table beg end props)
+  "Check TABLE for a completion matching the text between BEG and END.
+
+PROPS is a property list with additional information about TABLE.
+See `completion-at-point-functions' for more details.
+
+If TABLE contains a matching completion, return a list
+\(PREVIEW BEG END ALL EXIT-FN) where PREVIEW is the text to show
+in the completion preview, ALL is the list of all matching
+completion candidates, and EXIT-FN is either a function to call
+after inserting PREVIEW or nil.  If TABLE does not contain
+matching completions, or if there are multiple matching
+completions and `completion-preview-exact-match-only' is non-nil,
+return nil instead."
+  (let* ((pred (plist-get props :predicate))
+         (exit-fn (completion-preview--exit-function
+                   (plist-get props :exit-function)))
+         (string (buffer-substring beg end))
+         (md (completion-metadata string table pred))
+         (sort-fn (or (completion-metadata-get md 'cycle-sort-function)
+                      (completion-metadata-get md 'display-sort-function)
+                      completion-preview-sort-function))
+         (all (let ((completion-lazy-hilit t))
+                (completion-all-completions string table pred
+                                            (- (point) beg) md)))
+         (last (last all))
+         (base (or (cdr last) 0))
+         (prefix (substring string base)))
+    (when last
+      (setcdr last nil)
+      (when-let ((sorted (funcall sort-fn
+                                  (delete prefix (all-completions prefix 
all)))))
+        (unless (and (cdr sorted) completion-preview-exact-match-only)
+          (list (propertize (substring (car sorted) (length prefix))
+                            'face (if (cdr sorted)
+                                      'completion-preview
+                                    'completion-preview-exact))
+                (+ beg base) end sorted exit-fn))))))
+
+(defun completion-preview--capf-wrapper (capf)
+  "Translate return value of CAPF to properties for completion preview 
overlay."
+  (unless (eq capf #'completion-preview--insert)
+    (let ((res (ignore-errors (funcall capf))))
+      (and (consp res)
+           (not (functionp res))
+           (seq-let (beg end table &rest plist) res
+             (or (completion-preview--try-table table beg end plist)
+                 (unless (eq 'no (plist-get plist :exclusive))
+                   ;; Return non-nil to exclude other capfs.
+                   '(nil))))))))
+
 (defun completion-preview--update ()
   "Update completion preview."
-  (seq-let (beg end table &rest plist)
-      (let ((completion-preview-insert-on-completion nil))
-        (run-hook-with-args-until-success 'completion-at-point-functions))
-    (when (and beg end table)
-      (let* ((pred (plist-get plist :predicate))
-             (exit-fn (completion-preview--exit-function
-                       (plist-get plist :exit-function)))
-             (string (buffer-substring beg end))
-             (md (completion-metadata string table pred))
-             (sort-fn (or (completion-metadata-get md 'cycle-sort-function)
-                          (completion-metadata-get md 'display-sort-function)
-                          completion-preview-sort-function))
-             (all (let ((completion-lazy-hilit t))
-                    (completion-all-completions string table pred
-                                                (- (point) beg) md)))
-             (last (last all))
-             (base (or (cdr last) 0))
-             (bbeg (+ beg base))
-             (prefix (substring string base)))
-        (when last
-          (setcdr last nil)
-          (let* ((filtered (remove prefix (all-completions prefix all)))
-                 (sorted (funcall sort-fn filtered))
-                 (multi (cadr sorted))  ; multiple candidates
-                 (cand (car sorted)))
-            (when (and cand
-                       (not (and multi
-                                 completion-preview-exact-match-only)))
-              (let* ((face (if multi
-                               'completion-preview
-                             'completion-preview-exact))
-                     (after (propertize (substring cand (length prefix))
-                                        'face face))
-                     (ov (completion-preview--make-overlay end after)))
-                (overlay-put ov 'completion-preview-beg bbeg)
-                (overlay-put ov 'completion-preview-end end)
-                (overlay-put ov 'completion-preview-index 0)
-                (overlay-put ov 'completion-preview-cands sorted)
-                (overlay-put ov 'completion-preview-exit-fn exit-fn)
-                (completion-preview-active-mode)))))))))
+  (seq-let (preview beg end all exit-fn)
+      (run-hook-wrapped
+       'completion-at-point-functions
+       #'completion-preview--capf-wrapper)
+    (when preview
+      (let ((ov (completion-preview--make-overlay end preview)))
+        (overlay-put ov 'completion-preview-beg beg)
+        (overlay-put ov 'completion-preview-end end)
+        (overlay-put ov 'completion-preview-index 0)
+        (overlay-put ov 'completion-preview-cands all)
+        (overlay-put ov 'completion-preview-exit-fn exit-fn)
+        (completion-preview-active-mode)))))
 
 (defun completion-preview--show ()
   "Show a new completion preview.
diff --git a/test/lisp/completion-preview-tests.el 
b/test/lisp/completion-preview-tests.el
new file mode 100644
index 00000000000..b5518e96254
--- /dev/null
+++ b/test/lisp/completion-preview-tests.el
@@ -0,0 +1,184 @@
+;;; completion-preview-tests.el --- tests for completion-preview.el -*- 
lexical-binding: t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'completion-preview)
+
+(defun completion-preview-tests--capf (completions &rest props)
+  (lambda ()
+    (when-let ((bounds (bounds-of-thing-at-point 'symbol)))
+      (append (list (car bounds) (cdr bounds) completions) props))))
+
+(defun completion-preview-tests--check-preview (string &optional exact)
+  "Check that the completion preview is showing STRING.
+
+If EXACT is non-nil, check that STRING has the
+`completion-preview-exact' face.  Otherwise check that STRING has
+the `completion-preview' face.
+
+If STRING is nil, check that there is no completion preview
+instead."
+  (if (not string)
+      (should (not completion-preview--overlay))
+    (should completion-preview--overlay)
+    (let ((after-string (completion-preview--get 'after-string)))
+      (should (string= after-string string))
+      (should (eq (get-text-property 0 'face after-string)
+                  (if exact
+                      'completion-preview-exact
+                    'completion-preview))))))
+
+(ert-deftest completion-preview ()
+  "Test Completion Preview mode."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list (completion-preview-tests--capf '("foobarbaz"))))
+
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Exact match
+    (completion-preview-tests--check-preview "barbaz" 'exact)
+
+    (insert "v")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; No match, no preview
+    (completion-preview-tests--check-preview nil)
+
+    (delete-char -1)
+    (let ((this-command 'delete-backward-char))
+      (completion-preview--post-command))
+
+    ;; Exact match again
+    (completion-preview-tests--check-preview "barbaz" 'exact)))
+
+(ert-deftest completion-preview-multiple-matches ()
+  "Test Completion Preview mode with multiple matching candidates."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list (completion-preview-tests--capf
+                       '("foobar" "foobaz"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Multiple matches, the preview shows the first one
+    (completion-preview-tests--check-preview "bar")
+
+    (completion-preview-next-candidate 1)
+
+    ;; Next match
+    (completion-preview-tests--check-preview "baz")))
+
+(ert-deftest completion-preview-exact-match-only ()
+  "Test `completion-preview-exact-match-only'."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list (completion-preview-tests--capf
+                       '("spam" "foobar" "foobaz")))
+                completion-preview-exact-match-only t)
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Multiple matches, so no preview
+    (completion-preview-tests--check-preview nil)
+
+    (delete-region (point-min) (point-max))
+    (insert "spa")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Exact match
+    (completion-preview-tests--check-preview "m" 'exact)))
+
+(ert-deftest completion-preview-function-capfs ()
+  "Test Completion Preview mode with capfs that return a function."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (lambda () #'ignore)
+                 (completion-preview-tests--capf
+                  '("foobar" "foobaz"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "bar")))
+
+(ert-deftest completion-preview-non-exclusive-capfs ()
+  "Test Completion Preview mode with non-exclusive capfs."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (completion-preview-tests--capf
+                  '("spam") :exclusive 'no)
+                 (completion-preview-tests--capf
+                  '("foobar" "foobaz") :exclusive 'no)
+                 (completion-preview-tests--capf
+                  '("foobarbaz"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "bar")
+    (setq-local completion-preview-exact-match-only t)
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "barbaz" 'exact)))
+
+(ert-deftest completion-preview-face-updates ()
+  "Test updating the face in completion preview when match is no longer exact."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (completion-preview-tests--capf
+                  '("foobarbaz" "food"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "d")
+    (insert "b")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "arbaz" 'exact)
+    (delete-char -1)
+    (let ((this-command 'delete-backward-char))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "d")))
+
+(ert-deftest completion-preview-capf-errors ()
+  "Test Completion Preview mode with capfs that signal errors.
+
+`dabbrev-capf' is one example of such a capf."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (lambda () (user-error "bad"))
+                 (completion-preview-tests--capf
+                  '("foobarbaz"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "barbaz" 'exact)))
+
+;;; completion-preview-tests.el ends here