mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 06:20:55 -08:00
Code Issues Projects Releases Wiki Activity

New command 'completion-preview-complete'

Browse source 
This command completes the symbol at point up to the longest
common prefix of all completions candidates.  We also add an
indication of the longest common prefix in the completion
preview by highlighting that part of the preview with the
'completion-preview-exact' face.  To facilitate these features
we change the way we store the completion candidates while the
preview is visible, to explicitly keep the common prefix along
with a list of its suffixes.

* lisp/completion-preview.el (completion-preview--try-table):
Return longest common prefix and list of suffixes instead of
list of full candidates.  Add illustrative comment.
(completion-preview--capf-wrapper, completion-preview--update)
(completion-preview--show, completion-preview-insert)
(completion-preview-next-candidate): Adjust.
(completion-preview-common): New face.
(completion-preview-exact): Tweak to distinguish it from
'completion-preview-common'.
(completion-preview-complete): New command.
(completion-preview-active-mode-map): Bind it.
(completion-preview-mode): Mention it in docstring.
(completion-preview-commands): Add 'completion-preview-complete'.
(completion-preview--make-overlay): Simplify.
(completion-preview--internal-command-p): Remove.
(completion-preview-require-certain-commands): Update.
(completion-preview--inhibit-update): New inline function.
(completion-preview--inhibit-update-p): New local variable.
(completion-preview--post-command, completion-preview-hide):
Reset it to nil.

* test/lisp/completion-preview-tests.el
(completion-preview-tests--check-preview): Check the 'face'
property of both the first and last character.  Update callers.
(completion-preview-insert-calls-exit-function)
(completion-preview-complete): New tests.  (Bug#70381)
This commit is contained in:
Eshel Yaron 2024-04-12 22:41:10 +02:00
parent 12cd8d2615
commit 00caec8058
No known key found for this signature in database
GPG key ID: EF3EE9CA35D78618
2 changed files with 335 additions and 94 deletions
Download patch file Download diff file Expand all files Collapse all files

274
lisp/completion-preview.el
View file

@ -39,6 +39,16 @@
;; example, to M-n and M-p in `completion-preview-active-mode-map' to ;; example, to M-n and M-p in `completion-preview-active-mode-map' to
;; have them handy whenever the preview is visible. ;; have them handy whenever the preview is visible.
;; ;;
;; When the completion candidate that the preview is showing shares a
;; common prefix with all other candidates, Completion Preview mode
;; underlines that common prefix. If you want to insert the common
;; prefix but with a different suffix than the one the preview is
;; showing, use the command `completion-preview-complete'. This command
;; inserts just the common prefix and lets you go on typing as usual.
;; If you invoke `completion-preview-complete' when there is no common
;; prefix (so nothing is underlined in the preview), it displays a list
;; of all matching completion candidates.
;;
;; If you set the user option `completion-preview-exact-match-only' to ;; If you set the user option `completion-preview-exact-match-only' to
;; non-nil, Completion Preview mode only suggests a completion ;; non-nil, Completion Preview mode only suggests a completion
;; candidate when its the only possible completion for the (partial) ;; candidate when its the only possible completion for the (partial)
@ -73,7 +83,8 @@ first candidate, and you can cycle between the candidates with
insert-char insert-char
delete-backward-char delete-backward-char
backward-delete-char-untabify backward-delete-char-untabify
analyze-text-conversion) analyze-text-conversion
completion-preview-complete)
"List of commands that should trigger completion preview." "List of commands that should trigger completion preview."
:type '(repeat (function :tag "Command" :value self-insert-command)) :type '(repeat (function :tag "Command" :value self-insert-command))
:version "30.1") :version "30.1")
@ -104,16 +115,22 @@ If this option is nil, these commands do not display any message."
(defface completion-preview (defface completion-preview
'((t :inherit shadow)) '((t :inherit shadow))
"Face for completion preview overlay." "Face for completion candidates in the completion preview overlay."
:version "30.1") :version "30.1")
(defface completion-preview-exact (defface completion-preview-common
'((((supports :underline t)) '((((supports :underline t))
:underline t :inherit completion-preview) :underline t :inherit completion-preview)
(((supports :weight bold)) (((supports :weight bold))
:weight bold :inherit completion-preview) :weight bold :inherit completion-preview)
(t :background "gray")) (t :background "gray"))
"Face for exact completion preview overlay." "Face for the longest common prefix in the completion preview."
:version "30.1")
(defface completion-preview-exact
;; An exact match is also the longest common prefix of all matches.
'((t :underline "gray25" :inherit completion-preview-common))
"Face for matches in the completion preview overlay."
:version "30.1") :version "30.1")
(defface completion-preview-highlight (defface completion-preview-highlight
@ -124,6 +141,8 @@ If this option is nil, these commands do not display any message."
(defvar-keymap completion-preview-active-mode-map (defvar-keymap completion-preview-active-mode-map
:doc "Keymap for Completion Preview Active mode." :doc "Keymap for Completion Preview Active mode."
"C-i" #'completion-preview-insert "C-i" #'completion-preview-insert
;; FIXME: Should this have another/better binding by default?
"M-i" #'completion-preview-complete
;; "M-n" #'completion-preview-next-candidate ;; "M-n" #'completion-preview-next-candidate
;; "M-p" #'completion-preview-prev-candidate ;; "M-p" #'completion-preview-prev-candidate
) )
@ -131,8 +150,8 @@ If this option is nil, these commands do not display any message."
(defvar-keymap completion-preview--mouse-map (defvar-keymap completion-preview--mouse-map
:doc "Keymap for mouse clicks on the completion preview." :doc "Keymap for mouse clicks on the completion preview."
"<down-mouse-1>" #'completion-preview-insert "<down-mouse-1>" #'completion-preview-insert
"C-<down-mouse-1>" #'completion-at-point "C-<down-mouse-1>" #'completion-preview-complete
"<down-mouse-2>" #'completion-at-point "<down-mouse-2>" #'completion-preview-complete
"<wheel-up>" #'completion-preview-prev-candidate "<wheel-up>" #'completion-preview-prev-candidate
"<wheel-down>" #'completion-preview-next-candidate) "<wheel-down>" #'completion-preview-next-candidate)
@ -147,14 +166,16 @@ If this option is nil, these commands do not display any message."
Completion Preview mode avoids updating the preview after these commands.") Completion Preview mode avoids updating the preview after these commands.")
(defsubst completion-preview--internal-command-p () (defvar-local completion-preview--inhibit-update-p nil
"Return non-nil if `this-command' manipulates the completion preview." "Whether to inhibit updating the completion preview following this command.")
(memq this-command completion-preview--internal-commands))
(defsubst completion-preview--inhibit-update ()
"Inhibit updating the completion preview following this command."
(setq completion-preview--inhibit-update-p t))
(defsubst completion-preview-require-certain-commands () (defsubst completion-preview-require-certain-commands ()
"Check if `this-command' is one of `completion-preview-commands'." "Check if `this-command' is one of `completion-preview-commands'."
(or (completion-preview--internal-command-p) (memq this-command completion-preview-commands))
(memq this-command completion-preview-commands)))
(defun completion-preview-require-minimum-symbol-length () (defun completion-preview-require-minimum-symbol-length ()
"Check if the length of symbol at point is at least above a certain threshold. "Check if the length of symbol at point is at least above a certain threshold.
@ -167,7 +188,8 @@ Completion Preview mode avoids updating the preview after these commands.")
"Hide the completion preview." "Hide the completion preview."
(when completion-preview--overlay (when completion-preview--overlay
(delete-overlay completion-preview--overlay) (delete-overlay completion-preview--overlay)
(setq completion-preview--overlay nil))) (setq completion-preview--overlay nil
completion-preview--inhibit-update-p nil)))
(defun completion-preview--make-overlay (pos string) (defun completion-preview--make-overlay (pos string)
"Make preview overlay showing STRING at POS, or move existing preview there." "Make preview overlay showing STRING at POS, or move existing preview there."
@ -175,13 +197,9 @@ Completion Preview mode avoids updating the preview after these commands.")
(move-overlay completion-preview--overlay pos pos) (move-overlay completion-preview--overlay pos pos)
(setq completion-preview--overlay (make-overlay pos pos)) (setq completion-preview--overlay (make-overlay pos pos))
(overlay-put completion-preview--overlay 'window (selected-window))) (overlay-put completion-preview--overlay 'window (selected-window)))
(let ((previous (overlay-get completion-preview--overlay 'after-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) (add-text-properties 0 1 '(cursor 1) string)
(overlay-put completion-preview--overlay 'after-string string)) (overlay-put completion-preview--overlay 'after-string string)
completion-preview--overlay)) completion-preview--overlay)
(defsubst completion-preview--get (prop) (defsubst completion-preview--get (prop)
"Return property PROP of the completion preview overlay." "Return property PROP of the completion preview overlay."
@ -221,17 +239,25 @@ See also `completion-styles'.")
PROPS is a property list with additional information about TABLE. PROPS is a property list with additional information about TABLE.
See `completion-at-point-functions' for more details. See `completion-at-point-functions' for more details.
If TABLE contains a matching completion, return a list If TABLE contains a matching candidate, return a list
\(PREVIEW BEG END ALL BASE EXIT-FN) where PREVIEW is the text to \(BASE COMMON SUFFIXES) where BASE is a prefix of the text
show in the completion preview, ALL is the list of all matching between BEG and END that TABLE elided from the start of each candidate,
completion candidates, BASE is a common prefix that TABLE elided COMMON is the longest common prefix of all matching candidates,
from the start of each candidate, and EXIT-FN is either a SUFFIXES is a list of different suffixes that together with COMMON yield
function to call after inserting PREVIEW or nil. If TABLE does the matching candidates. If TABLE does not contain matching
not contain matching completions, or if there are multiple candidates or if there are multiple matching completions and
matching completions and `completion-preview-exact-match-only' is `completion-preview-exact-match-only' is non-nil, return nil instead."
non-nil, return nil instead." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; | buffer text | preview | ;;
;; | | | ;;
;; beg end | ;;
;; |------+------|--+--------| Each of base, common and suffix ;;
;; | base | common | suffix | <- may be empty, except common and ;;
;; suffix cannot both be empty. ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let* ((pred (plist-get props :predicate)) (let* ((pred (plist-get props :predicate))
(exit-fn (plist-get props :exit-function))
(string (buffer-substring beg end)) (string (buffer-substring beg end))
(md (completion-metadata string table pred)) (md (completion-metadata string table pred))
(sort-fn (or (completion-metadata-get md 'cycle-sort-function) (sort-fn (or (completion-metadata-get md 'cycle-sort-function)
@ -250,16 +276,16 @@ non-nil, return nil instead."
(when last (when last
(setcdr last nil) (setcdr last nil)
(when-let ((sorted (funcall sort-fn (when-let ((sorted (funcall sort-fn
(delete prefix (all-completions prefix all))))) (delete prefix (all-completions prefix all))))
(unless (and (cdr sorted) completion-preview-exact-match-only) (common (try-completion prefix sorted))
(list (propertize (substring (car sorted) (length prefix)) (lencom (length common))
'face (if (cdr sorted) (suffixes sorted))
'completion-preview (unless (and (cdr suffixes) completion-preview-exact-match-only)
'completion-preview-exact) ;; Remove the common prefix from each candidate.
'mouse-face 'completion-preview-highlight (while sorted
'keymap completion-preview--mouse-map) (setcar sorted (substring (car sorted) lencom))
(+ beg base) end sorted (setq sorted (cdr sorted)))
(substring string 0 base) exit-fn)))))) (list (substring string 0 base) common suffixes))))))
(defun completion-preview--capf-wrapper (capf) (defun completion-preview--capf-wrapper (capf)
"Translate return value of CAPF to properties for completion preview overlay." "Translate return value of CAPF to properties for completion preview overlay."
@ -267,25 +293,41 @@ non-nil, return nil instead."
(and (consp res) (and (consp res)
(not (functionp res)) (not (functionp res))
(seq-let (beg end table &rest plist) res (seq-let (beg end table &rest plist) res
(or (completion-preview--try-table table beg end plist) (or (when-let ((data (completion-preview--try-table
table beg end plist)))
`(,(+ beg (length (car data))) ,end ,plist ,@data))
(unless (eq 'no (plist-get plist :exclusive)) (unless (eq 'no (plist-get plist :exclusive))
;; Return non-nil to exclude other capfs. ;; Return non-nil to exclude other capfs.
'(nil))))))) '(nil)))))))
(defun completion-preview--update () (defun completion-preview--update ()
"Update completion preview." "Update completion preview."
(seq-let (preview beg end all base exit-fn) (seq-let (beg end props base common suffixes)
(run-hook-wrapped (run-hook-wrapped
'completion-at-point-functions 'completion-at-point-functions
#'completion-preview--capf-wrapper) #'completion-preview--capf-wrapper)
(when preview (when-let ((suffix (car suffixes)))
(let ((ov (completion-preview--make-overlay end preview))) (set-text-properties 0 (length suffix)
(list 'face (if (cdr suffixes)
'completion-preview
'completion-preview-exact))
suffix)
(set-text-properties 0 (length common)
(list 'face (if (cdr suffixes)
'completion-preview-common
'completion-preview-exact))
common)
(let ((ov (completion-preview--make-overlay
end (propertize (concat (substring common (- end beg)) suffix)
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map))))
(overlay-put ov 'completion-preview-beg beg) (overlay-put ov 'completion-preview-beg beg)
(overlay-put ov 'completion-preview-end end) (overlay-put ov 'completion-preview-end end)
(overlay-put ov 'completion-preview-index 0) (overlay-put ov 'completion-preview-index 0)
(overlay-put ov 'completion-preview-cands all) (overlay-put ov 'completion-preview-suffixes suffixes)
(overlay-put ov 'completion-preview-common common)
(overlay-put ov 'completion-preview-base base) (overlay-put ov 'completion-preview-base base)
(overlay-put ov 'completion-preview-exit-fn exit-fn) (overlay-put ov 'completion-preview-props props)
(completion-preview-active-mode))))) (completion-preview-active-mode)))))
(defun completion-preview--show () (defun completion-preview--show ()
@ -308,17 +350,22 @@ point, otherwise hide it."
;; flicker, even with slow completion backends. ;; flicker, even with slow completion backends.
(let* ((beg (completion-preview--get 'completion-preview-beg)) (let* ((beg (completion-preview--get 'completion-preview-beg))
(end (max (point) (overlay-start completion-preview--overlay))) (end (max (point) (overlay-start completion-preview--overlay)))
(cands (completion-preview--get 'completion-preview-cands)) (sufs (completion-preview--get 'completion-preview-suffixes))
(index (completion-preview--get 'completion-preview-index)) (index (completion-preview--get 'completion-preview-index))
(cand (nth index cands)) (common (completion-preview--get 'completion-preview-common))
(after (completion-preview--get 'after-string)) (suffix (nth index sufs))
(face (get-text-property 0 'face after))) (cand nil))
(set-text-properties 0 (length suffix)
(list 'face (if (cdr sufs)
'completion-preview
'completion-preview-exact))
suffix)
(setq cand (concat common (nth index sufs)))
(if (and (<= beg (point) end (1- (+ beg (length cand)))) (if (and (<= beg (point) end (1- (+ beg (length cand))))
(string-prefix-p (buffer-substring beg end) cand)) (string-prefix-p (buffer-substring beg end) cand))
;; The previous preview is still applicable, update it. ;; The previous preview is still applicable, update it.
(overlay-put (completion-preview--make-overlay (overlay-put (completion-preview--make-overlay
end (propertize (substring cand (- end beg)) end (propertize (substring cand (- end beg))
'face face
'mouse-face 'completion-preview-highlight 'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map)) 'keymap completion-preview--mouse-map))
'completion-preview-end end) 'completion-preview-end end)
@ -329,16 +376,18 @@ point, otherwise hide it."
(defun completion-preview--post-command () (defun completion-preview--post-command ()
"Create, update or delete completion preview post last command." "Create, update or delete completion preview post last command."
(if (and (completion-preview-require-certain-commands) (let ((internal-p (or completion-preview--inhibit-update-p
(completion-preview-require-minimum-symbol-length)) (memq this-command
;; We should show the preview. completion-preview--internal-commands))))
(or (setq completion-preview--inhibit-update-p nil)
;; If we're called after a command that itself updates the ;; If we're called after a command that itself updates the
;; preview, don't do anything. ;; preview, don't do anything.
(completion-preview--internal-command-p) (unless internal-p
;; Otherwise, show the preview. (if (and (completion-preview-require-certain-commands)
(completion-preview--show)) (completion-preview-require-minimum-symbol-length))
(completion-preview-active-mode -1))) (completion-preview--show)
(completion-preview-active-mode -1)))))
(defun completion-preview-insert () (defun completion-preview-insert ()
"Insert the completion candidate that the preview is showing." "Insert the completion candidate that the preview is showing."
@ -347,16 +396,84 @@ point, otherwise hide it."
(let* ((pre (completion-preview--get 'completion-preview-base)) (let* ((pre (completion-preview--get 'completion-preview-base))
(end (completion-preview--get 'completion-preview-end)) (end (completion-preview--get 'completion-preview-end))
(ind (completion-preview--get 'completion-preview-index)) (ind (completion-preview--get 'completion-preview-index))
(all (completion-preview--get 'completion-preview-cands)) (all (completion-preview--get 'completion-preview-suffixes))
(efn (completion-preview--get 'completion-preview-exit-fn)) (com (completion-preview--get 'completion-preview-common))
(efn (plist-get (completion-preview--get 'completion-preview-props)
:exit-function))
(aft (completion-preview--get 'after-string)) (aft (completion-preview--get 'after-string))
(str (concat pre (nth ind all)))) (str (concat pre com (nth ind all))))
(completion-preview-active-mode -1) (completion-preview-active-mode -1)
(goto-char end) (goto-char end)
(insert (substring-no-properties aft)) (insert (substring-no-properties aft))
(when (functionp efn) (funcall efn str 'finished))) (when (functionp efn) (funcall efn str 'finished)))
(user-error "No current completion preview"))) (user-error "No current completion preview")))
(defun completion-preview-complete ()
"Complete up to the longest common prefix of all completion candidates.
If you call this command twice in a row, or otherwise if there is no
common prefix to insert, it displays the list of matching completion
candidates unless `completion-auto-help' is nil. If you repeat this
command again when the completions list is visible, it scrolls the
completions list."
(interactive)
(unless completion-preview-active-mode
(user-error "No current completion preview"))
(let* ((beg (completion-preview--get 'completion-preview-beg))
(end (completion-preview--get 'completion-preview-end))
(com (completion-preview--get 'completion-preview-common))
(cur (completion-preview--get 'completion-preview-index))
(all (completion-preview--get 'completion-preview-suffixes))
(base (completion-preview--get 'completion-preview-base))
(props (completion-preview--get 'completion-preview-props))
(efn (plist-get props :exit-function))
(ins (substring-no-properties com (- end beg))))
(goto-char end)
(if (string-empty-p ins)
;; If there's nothing to insert, call `completion-at-point' to
;; show the completions list (or just display a message when
;; `completion-auto-help' is nil).
(let* ((completion-styles completion-preview-completion-styles)
(sub (substring-no-properties com))
(col (mapcar (lambda (suf)
(concat sub (substring-no-properties suf)))
(append (nthcdr cur all) (take cur all))))
;; The candidates are already in order.
(props (plist-put props :display-sort-function #'identity))
;; The :exit-function might be slow, e.g. when the
;; backend is Eglot, so we ensure that the preview is
;; hidden before any original :exit-function is called.
(props (plist-put props :exit-function
(when (functionp efn)
(lambda (string status)
(completion-preview-active-mode -1)
(funcall efn string status)))))
;; The predicate is meant for the original completion
;; candidates, which may be symbols or cons cells, but
;; now we only have strings, so it might be unapplicable.
(props (plist-put props :predicate nil))
(completion-at-point-functions
(list (lambda () `(,beg ,end ,col ,@props)))))
(completion-preview--inhibit-update)
(completion-at-point))
;; Otherwise, insert the common prefix and update the preview.
(insert ins)
(let ((suf (nth cur all))
(pos (point)))
(if (or (string-empty-p suf) (null suf))
;; If we've inserted a full candidate, let the post-command
;; hook update the completion preview in case the candidate
;; can be completed further.
(when (functionp efn)
(funcall efn (concat base com) (if (cdr all) 'exact 'finished)))
;; Otherwise, remove the common prefix from the preview.
(completion-preview--inhibit-update)
(overlay-put (completion-preview--make-overlay
pos (propertize
suf 'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map))
'completion-preview-end pos))))))
(defun completion-preview-prev-candidate () (defun completion-preview-prev-candidate ()
"Cycle the candidate that the preview is showing to the previous suggestion." "Cycle the candidate that the preview is showing to the previous suggestion."
(interactive) (interactive)
@ -372,18 +489,29 @@ prefix argument and defaults to 1."
(when completion-preview-active-mode (when completion-preview-active-mode
(let* ((beg (completion-preview--get 'completion-preview-beg)) (let* ((beg (completion-preview--get 'completion-preview-beg))
(end (completion-preview--get 'completion-preview-end)) (end (completion-preview--get 'completion-preview-end))
(all (completion-preview--get 'completion-preview-cands)) (all (completion-preview--get 'completion-preview-suffixes))
(com (completion-preview--get 'completion-preview-common))
(cur (completion-preview--get 'completion-preview-index)) (cur (completion-preview--get 'completion-preview-index))
(len (length all)) (len (length all))
(new (mod (+ cur direction) len)) (new (mod (+ cur direction) len))
(str (nth new all))) (suf (nth new all))
(while (or (<= (+ beg (length str)) end) (lencom (length com)))
(not (string-prefix-p (buffer-substring beg end) str))) ;; Skip suffixes that are no longer applicable. This may happen
(setq new (mod (+ new direction) len) str (nth new all))) ;; when the user continues typing and immediately runs this
(let ((aft (propertize (substring str (- end beg)) ;; command, before the completion backend returns an updated set
'face (if (< 1 len) ;; of completions for the new (longer) prefix, so we still have
;; the previous (larger) set of candidates at hand.
(while (or (<= (+ beg lencom (length suf)) end)
(not (string-prefix-p (buffer-substring beg end)
(concat com suf))))
(setq new (mod (+ new direction) len)
suf (nth new all)))
(set-text-properties 0 (length suf)
(list 'face (if (cdr all)
'completion-preview 'completion-preview
'completion-preview-exact) 'completion-preview-exact))
suf)
(let ((aft (propertize (substring (concat com suf) (- end beg))
'mouse-face 'completion-preview-highlight 'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map))) 'keymap completion-preview--mouse-map)))
(add-text-properties 0 1 '(cursor 1) aft) (add-text-properties 0 1 '(cursor 1) aft)
@ -398,6 +526,7 @@ prefix argument and defaults to 1."
(buffer-local-value 'completion-preview-active-mode buffer)) (buffer-local-value 'completion-preview-active-mode buffer))
(dolist (cmd '(completion-preview-insert (dolist (cmd '(completion-preview-insert
completion-preview-complete
completion-preview-prev-candidate completion-preview-prev-candidate
completion-preview-next-candidate)) completion-preview-next-candidate))
(put cmd 'completion-predicate #'completion-preview--active-p)) (put cmd 'completion-predicate #'completion-preview--active-p))
@ -409,11 +538,12 @@ prefix argument and defaults to 1."
This mode automatically shows and updates the completion preview This mode automatically shows and updates the completion preview
according to the text around point. according to the text around point.
\\<completion-preview-active-mode-map>\ \\<completion-preview-active-mode-map>\
When the preview is visible, \\[completion-preview-insert] When the preview is visible, \\[completion-preview-insert] accepts the
accepts the completion suggestion, completion suggestion, \\[completion-preview-complete] completes up to
the longest common prefix of all completion candidates,
\\[completion-preview-next-candidate] cycles forward to the next \\[completion-preview-next-candidate] cycles forward to the next
completion suggestion, and \\[completion-preview-prev-candidate] completion suggestion, and \\[completion-preview-prev-candidate] cycles
cycles backward." backward."
:lighter " CP" :lighter " CP"
(if completion-preview-mode (if completion-preview-mode
(add-hook 'post-command-hook #'completion-preview--post-command nil t) (add-hook 'post-command-hook #'completion-preview--post-command nil t)

147
test/lisp/completion-preview-tests.el
View file

@ -27,23 +27,25 @@
(when-let ((bounds (bounds-of-thing-at-point 'symbol))) (when-let ((bounds (bounds-of-thing-at-point 'symbol)))
(append (list (car bounds) (cdr bounds) completions) props)))) (append (list (car bounds) (cdr bounds) completions) props))))
(defun completion-preview-tests--check-preview (string &optional exact) (defun completion-preview-tests--check-preview
(string &optional beg-face end-face)
"Check that the completion preview is showing STRING. "Check that the completion preview is showing STRING.
If EXACT is non-nil, check that STRING has the BEG-FACE and END-FACE say which faces the beginning and end of STRING
`completion-preview-exact' face. Otherwise check that STRING has should have, respectively. Both BEG-FACE and END-FACE default to
the `completion-preview' face. `completion-preview'.
If STRING is nil, check that there is no completion preview If STRING is nil, check that there is no completion preview
instead." instead."
(if (not string) (if (not string)
(should (not completion-preview--overlay)) (should-not completion-preview--overlay)
(should completion-preview--overlay) (should completion-preview--overlay)
(let ((after-string (completion-preview--get 'after-string))) (let ((after-string (completion-preview--get 'after-string)))
(should (string= after-string string)) (should (string= after-string string))
(should (eq (get-text-property 0 'face after-string) (should (eq (get-text-property 0 'face after-string)
(if exact (or beg-face 'completion-preview)))
'completion-preview-exact (should (eq (get-text-property (1- (length after-string)) 'face after-string)
(or end-face
'completion-preview)))))) 'completion-preview))))))
(ert-deftest completion-preview () (ert-deftest completion-preview ()
@ -57,7 +59,9 @@ instead."
(completion-preview--post-command)) (completion-preview--post-command))
;; Exact match ;; Exact match
(completion-preview-tests--check-preview "barbaz" 'exact) (completion-preview-tests--check-preview "barbaz"
'completion-preview-exact
'completion-preview-exact)
(insert "v") (insert "v")
(let ((this-command 'self-insert-command)) (let ((this-command 'self-insert-command))
@ -71,7 +75,9 @@ instead."
(completion-preview--post-command)) (completion-preview--post-command))
;; Exact match again ;; Exact match again
(completion-preview-tests--check-preview "barbaz" 'exact))) (completion-preview-tests--check-preview "barbaz"
'completion-preview-exact
'completion-preview-exact)))
(ert-deftest completion-preview-multiple-matches () (ert-deftest completion-preview-multiple-matches ()
"Test Completion Preview mode with multiple matching candidates." "Test Completion Preview mode with multiple matching candidates."
@ -84,12 +90,12 @@ instead."
(completion-preview--post-command)) (completion-preview--post-command))
;; Multiple matches, the preview shows the first one ;; Multiple matches, the preview shows the first one
(completion-preview-tests--check-preview "bar") (completion-preview-tests--check-preview "bar" 'completion-preview-common)
(completion-preview-next-candidate 1) (completion-preview-next-candidate 1)
;; Next match ;; Next match
(completion-preview-tests--check-preview "baz"))) (completion-preview-tests--check-preview "baz" 'completion-preview-common)))
(ert-deftest completion-preview-exact-match-only () (ert-deftest completion-preview-exact-match-only ()
"Test `completion-preview-exact-match-only'." "Test `completion-preview-exact-match-only'."
@ -111,7 +117,9 @@ instead."
(completion-preview--post-command)) (completion-preview--post-command))
;; Exact match ;; Exact match
(completion-preview-tests--check-preview "m" 'exact))) (completion-preview-tests--check-preview "m"
'completion-preview-exact
'completion-preview-exact)))
(ert-deftest completion-preview-function-capfs () (ert-deftest completion-preview-function-capfs ()
"Test Completion Preview mode with capfs that return a function." "Test Completion Preview mode with capfs that return a function."
@ -124,7 +132,7 @@ instead."
(insert "foo") (insert "foo")
(let ((this-command 'self-insert-command)) (let ((this-command 'self-insert-command))
(completion-preview--post-command)) (completion-preview--post-command))
(completion-preview-tests--check-preview "bar"))) (completion-preview-tests--check-preview "bar" 'completion-preview-common)))
(ert-deftest completion-preview-non-exclusive-capfs () (ert-deftest completion-preview-non-exclusive-capfs ()
"Test Completion Preview mode with non-exclusive capfs." "Test Completion Preview mode with non-exclusive capfs."
@ -140,11 +148,13 @@ instead."
(insert "foo") (insert "foo")
(let ((this-command 'self-insert-command)) (let ((this-command 'self-insert-command))
(completion-preview--post-command)) (completion-preview--post-command))
(completion-preview-tests--check-preview "bar") (completion-preview-tests--check-preview "bar" 'completion-preview-common)
(setq-local completion-preview-exact-match-only t) (setq-local completion-preview-exact-match-only t)
(let ((this-command 'self-insert-command)) (let ((this-command 'self-insert-command))
(completion-preview--post-command)) (completion-preview--post-command))
(completion-preview-tests--check-preview "barbaz" 'exact))) (completion-preview-tests--check-preview "barbaz"
'completion-preview-exact
'completion-preview-exact)))
(ert-deftest completion-preview-face-updates () (ert-deftest completion-preview-face-updates ()
"Test updating the face in completion preview when match is no longer exact." "Test updating the face in completion preview when match is no longer exact."
@ -160,7 +170,9 @@ instead."
(insert "b") (insert "b")
(let ((this-command 'self-insert-command)) (let ((this-command 'self-insert-command))
(completion-preview--post-command)) (completion-preview--post-command))
(completion-preview-tests--check-preview "arbaz" 'exact) (completion-preview-tests--check-preview "arbaz"
'completion-preview-exact
'completion-preview-exact)
(delete-char -1) (delete-char -1)
(let ((this-command 'delete-backward-char)) (let ((this-command 'delete-backward-char))
(completion-preview--post-command)) (completion-preview--post-command))
@ -173,13 +185,15 @@ instead."
(with-temp-buffer (with-temp-buffer
(setq-local completion-at-point-functions (setq-local completion-at-point-functions
(list (list
(lambda () (user-error "bad")) (lambda () (user-error "Bad"))
(completion-preview-tests--capf (completion-preview-tests--capf
'("foobarbaz")))) '("foobarbaz"))))
(insert "foo") (insert "foo")
(let ((this-command 'self-insert-command)) (let ((this-command 'self-insert-command))
(completion-preview--post-command)) (completion-preview--post-command))
(completion-preview-tests--check-preview "barbaz" 'exact))) (completion-preview-tests--check-preview "barbaz"
'completion-preview-exact
'completion-preview-exact)))
(ert-deftest completion-preview-mid-symbol-cycle () (ert-deftest completion-preview-mid-symbol-cycle ()
"Test cycling the completion preview with point at the middle of a symbol." "Test cycling the completion preview with point at the middle of a symbol."
@ -196,4 +210,101 @@ instead."
(completion-preview-next-candidate 1) (completion-preview-next-candidate 1)
(completion-preview-tests--check-preview "z"))) (completion-preview-tests--check-preview "z")))
(ert-deftest completion-preview-complete ()
"Test `completion-preview-complete'."
(with-temp-buffer
(let ((exit-fn-called nil)
(exit-fn-args nil)
(message-args nil)
(completion-auto-help nil))
(setq-local completion-at-point-functions
(list
(completion-preview-tests--capf
'("foobar" "foobaz" "foobash" "foobash-mode")
:exit-function
(lambda (&rest args)
(setq exit-fn-called t
exit-fn-args args)))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(message "here")
(completion-preview-tests--check-preview "bar" 'completion-preview-common)
;; Insert the common prefix, "ba".
(completion-preview-complete)
;; Only "r" should remain.
(completion-preview-tests--check-preview "r")
(cl-letf (((symbol-function #'minibuffer-message)
(lambda (&rest args) (setq message-args args))))
;; With `completion-auto-help' set to nil, a second call to
;; `completion-preview-complete' just displays a message.
(completion-preview-complete)
(setq completion-preview--inhibit-update-p nil)
(should (equal message-args '("Next char not unique"))))
;; The preview should stay put.
(completion-preview-tests--check-preview "r")
;; (completion-preview-active-mode -1)
;; Narrow further.
(insert "s")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
;; The preview should indicate an exact match.
(completion-preview-tests--check-preview "h"
'completion-preview-common
'completion-preview-common)
;; Insert the entire preview content.
(completion-preview-complete)
(setq completion-preview--inhibit-update-p nil)
(let ((this-command 'completion-preview-complete))
(completion-preview--post-command))
;; The preview should update to indicate that there's a further
;; possible completion.
(completion-preview-tests--check-preview "-mode"
'completion-preview-exact
'completion-preview-exact)
(should exit-fn-called)
(should (equal exit-fn-args '("foobash" exact)))
(setq exit-fn-called nil exit-fn-args nil)
;; Insert the extra suffix.
(completion-preview-complete)
;; Nothing more to show, so the preview should now be gone.
(should-not completion-preview--overlay)
(should exit-fn-called)
(should (equal exit-fn-args '("foobash-mode" finished))))))
(ert-deftest completion-preview-insert-calls-exit-function ()
"Test that `completion-preview-insert' calls the completion exit function."
(let ((exit-fn-called nil) (exit-fn-args nil))
(with-temp-buffer
(setq-local completion-at-point-functions
(list
(completion-preview-tests--capf
'("foobar" "foobaz")
:exit-function
(lambda (&rest args)
(setq exit-fn-called t
exit-fn-args args)))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(completion-preview-tests--check-preview "bar" 'completion-preview-common)
(completion-preview-insert)
(should (string= (buffer-string) "foobar"))
(should-not completion-preview--overlay)
(should exit-fn-called)
(should (equal exit-fn-args '("foobar" finished))))))
;;; completion-preview-tests.el ends here ;;; completion-preview-tests.el ends here