>From f6a4eac72e8439ad61a2d71e8e376db0d9d55064 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Sun, 19 Nov 2023 10:55:15 +0100 Subject: [PATCH] ; 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. --- lisp/completion-preview.el | 114 ++++++++++------ test/lisp/completion-preview-tests.el | 184 ++++++++++++++++++++++++++ 2 files changed, 257 insertions(+), 41 deletions(-) create mode 100644 test/lisp/completion-preview-tests.el diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index 6048d5be272..2b81dc5cd61 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -155,7 +155,9 @@ completion-preview--make-overlay (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,78 @@ completion-preview--exit-function (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. + +When 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. When TABLE does not contain +matching completions, or when 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 output of CAPF to properties for completion preview overlay. + +If CAPF returns a list (BEG END TABLE . PROPS), call +`completion-preview--try-table' to check TABLE for matching +completion candidates. If `completion-preview--try-table' +returns a non-nil value, return that value. Otherwise, return a +list with nil car which means that completion failed, unless +PROPS includes the property `:exclusive' with value `no', in +which case this function returns nil which means to try other +functions from `completion-at-point-functions'." + (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) + (and (not (eq 'no (plist-get plist :exclusive))) '(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 . + +;;; 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 -- 2.42.0