[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 3c3c46f4298 1/2: ; Improve and add tests for Completion Preview m
From: |
Eli Zaretskii |
Subject: |
master 3c3c46f4298 1/2: ; Improve and add tests for Completion Preview mode |
Date: |
Sat, 25 Nov 2023 05:10:40 -0500 (EST) |
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