* bug#70381: [PATCH] New command 'completion-preview-complete'
@ 2024-04-14 11:21 Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-04-14 12:01 ` Eli Zaretskii
0 siblings, 1 reply; 5+ messages in thread
From: Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors @ 2024-04-14 11:21 UTC (permalink / raw)
To: 70381; +Cc: Ergus
[-- Attachment #1: Type: text/plain, Size: 1724 bytes --]
Tags: patch
Following a recent discussion on emacs-devel[0], this patch adds a new
command for Completion Preview mode that completes the symbol at point up
to the longest common prefix of all completion candidates. This patch
also adds a visual indication for the longest common prefix when showing
it as part of the completion preview, so the user can tell how far the new
'completion-preview-complete' will complete before invoking this command.
For example, if the symbol at point is "foo", and the completion
candidates are "foobar" and "foobaz", then the preview shows "bar" with
the common prefix "ba" highlighted in face 'completion-preview-common'.
To provide this feature efficiently, this patch modifies the way we store
the completion candidates while the preview is visible. This amounts to
quite a few changes, so I added some tests to make sure nothing breaks,
and a bunch of comments to clarify what each part is doing.
One thing I'm not sure about is the keybinding for the new command. In
Company, the command that inserts the common part (like the new
'completion-preview-complete' does) is bound to TAB, but we already use
TAB for 'completion-preview-insert', which inserts the entire candidate.
(Note that these bindings are only in effect when the preview is visible.)
The analogous command to 'completion-preview-insert' in Company is bound
to RET, but I feel that binding RET may be too intrusive to do by default.
For demonstration purposes, 'completion-preview-complete' is bound to M-i
in this patch. Suggestions for a better choice of keybinding, and any
other comments, would be most welcome :)
Thanks,
Eshel
[0] https://lists.gnu.org/archive/html/emacs-devel/2024-04/msg00154.html
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-New-command-completion-preview-complete.patch --]
[-- Type: text/patch, Size: 35945 bytes --]
From c2f7159bb7b2647aee2d76f26a9c46982efbe2b5 Mon Sep 17 00:00:00 2001
From: Eshel Yaron <me@eshelyaron.com>
Date: Fri, 12 Apr 2024 22:41:10 +0200
Subject: [PATCH] New command 'completion-preview-complete'
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): Distinguish from 'c-p-common'.
(completion-preview-complete): New command.
(completion-preview-active-mode-map): Bind it.
(completion-preview-mode): Mention it in docstring.
(completion-preview-commands): Add 'c-p-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.
---
lisp/completion-preview.el | 280 +++++++++++++++++++-------
test/lisp/completion-preview-tests.el | 147 ++++++++++++--
2 files changed, 334 insertions(+), 93 deletions(-)
diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 4e52aa9b151..653c45e575b 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -39,6 +39,16 @@
;; example, to M-n and M-p in `completion-preview-active-mode-map' to
;; 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
;; non-nil, Completion Preview mode only suggests a completion
;; candidate when its the only possible completion for the (partial)
@@ -73,7 +83,8 @@ completion-preview-commands
insert-char
delete-backward-char
backward-delete-char-untabify
- analyze-text-conversion)
+ analyze-text-conversion
+ completion-preview-complete)
"List of commands that should trigger completion preview."
:type '(repeat (function :tag "Command" :value self-insert-command))
:version "30.1")
@@ -104,16 +115,22 @@ completion-preview-sort-function
(defface completion-preview
'((t :inherit shadow))
- "Face for completion preview overlay."
+ "Face for completion candidates in the completion preview overlay."
:version "30.1")
-(defface completion-preview-exact
+(defface completion-preview-common
'((((supports :underline t))
:underline t :inherit completion-preview)
(((supports :weight bold))
:weight bold :inherit completion-preview)
(t :background "gray"))
- "Face for exact completion preview overlay."
+ "Face for completions 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")
(defface completion-preview-highlight
@@ -124,6 +141,8 @@ completion-preview-highlight
(defvar-keymap completion-preview-active-mode-map
:doc "Keymap for Completion Preview Active mode."
"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-p" #'completion-preview-prev-candidate
)
@@ -131,8 +150,8 @@ completion-preview-active-mode-map
(defvar-keymap completion-preview--mouse-map
:doc "Keymap for mouse clicks on the completion preview."
"<down-mouse-1>" #'completion-preview-insert
- "C-<down-mouse-1>" #'completion-at-point
- "<down-mouse-2>" #'completion-at-point
+ "C-<down-mouse-1>" #'completion-preview-complete
+ "<down-mouse-2>" #'completion-preview-complete
"<wheel-up>" #'completion-preview-prev-candidate
"<wheel-down>" #'completion-preview-next-candidate)
@@ -147,14 +166,16 @@ completion-preview--internal-commands
Completion Preview mode avoids updating the preview after these commands.")
-(defsubst completion-preview--internal-command-p ()
- "Return non-nil if `this-command' manipulates the completion preview."
- (memq this-command completion-preview--internal-commands))
+(defvar-local completion-preview--inhibit-update-p nil
+ "Whether to inhibit updateing the completion preview following this command.")
+
+(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 ()
"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 ()
"Check if the length of symbol at point is at least above a certain threshold.
@@ -167,7 +188,8 @@ completion-preview-hide
"Hide the completion preview."
(when 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)
"Make preview overlay showing STRING at POS, or move existing preview there."
@@ -175,13 +197,9 @@ completion-preview--make-overlay
(move-overlay completion-preview--overlay pos pos)
(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)
- (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))
+ (add-text-properties 0 1 '(cursor 1) string)
+ (overlay-put completion-preview--overlay 'after-string string)
+ completion-preview--overlay)
(defsubst completion-preview--get (prop)
"Return property PROP of the completion preview overlay."
@@ -221,17 +239,25 @@ completion-preview--try-table
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 BASE EXIT-FN) where PREVIEW is the text to
-show in the completion preview, ALL is the list of all matching
-completion candidates, BASE is a common prefix that TABLE elided
-from the start of each candidate, 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."
+If TABLE contains a matching candidate, return a list
+\(BASE COMMON SUFFIXES) where BASE is a prefix of the text
+between BEG and END that TABLE elided from the start of each candidate,
+COMMON is the longest common prefix of all matching candidates,
+SUFFIXES is a list of different suffixes that together with COMMON yield
+the matching candidates. If TABLE does not contain matching
+candidates or if there are multiple matching completions and
+`completion-preview-exact-match-only' is 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))
- (exit-fn (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)
@@ -250,16 +276,16 @@ completion-preview--try-table
(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)
- 'mouse-face 'completion-preview-highlight
- 'keymap completion-preview--mouse-map)
- (+ beg base) end sorted
- (substring string 0 base) exit-fn))))))
+ (delete prefix (all-completions prefix all))))
+ (common (try-completion prefix sorted))
+ (lencom (length common))
+ (suffixes sorted))
+ (unless (and (cdr suffixes) completion-preview-exact-match-only)
+ ;; Remove the common prefix from each candidate.
+ (while sorted
+ (setcar sorted (substring (car sorted) lencom))
+ (setq sorted (cdr sorted)))
+ (list (substring string 0 base) common suffixes))))))
(defun completion-preview--capf-wrapper (capf)
"Translate return value of CAPF to properties for completion preview overlay."
@@ -267,25 +293,41 @@ completion-preview--capf-wrapper
(and (consp res)
(not (functionp 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))
;; Return non-nil to exclude other capfs.
'(nil)))))))
(defun completion-preview--update ()
"Update completion preview."
- (seq-let (preview beg end all base exit-fn)
+ (seq-let (beg end props base common suffixes)
(run-hook-wrapped
'completion-at-point-functions
#'completion-preview--capf-wrapper)
- (when preview
- (let ((ov (completion-preview--make-overlay end preview)))
+ (when-let ((suffix (car suffixes)))
+ (set-text-properties 0 (length suffix)
+ `(face ,(if (cdr suffixes)
+ 'completion-preview
+ 'completion-preview-exact))
+ suffix)
+ (set-text-properties 0 (length common)
+ `(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-end end)
(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-exit-fn exit-fn)
+ (overlay-put ov 'completion-preview-props props)
(completion-preview-active-mode)))))
(defun completion-preview--show ()
@@ -308,17 +350,22 @@ completion-preview--show
;; flicker, even with slow completion backends.
(let* ((beg (completion-preview--get 'completion-preview-beg))
(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))
- (cand (nth index cands))
- (after (completion-preview--get 'after-string))
- (face (get-text-property 0 'face after)))
+ (common (completion-preview--get 'completion-preview-common))
+ (suffix (nth index sufs))
+ (cand nil))
+ (set-text-properties 0 (length suffix)
+ `(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))))
(string-prefix-p (buffer-substring beg end) cand))
;; The previous preview is still applicable, update it.
(overlay-put (completion-preview--make-overlay
end (propertize (substring cand (- end beg))
- 'face face
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map))
'completion-preview-end end)
@@ -329,16 +376,18 @@ completion-preview--show
(defun completion-preview--post-command ()
"Create, update or delete completion preview post last command."
- (if (and (completion-preview-require-certain-commands)
- (completion-preview-require-minimum-symbol-length))
- ;; We should show the preview.
- (or
- ;; If we're called after a command that itself updates the
- ;; preview, don't do anything.
- (completion-preview--internal-command-p)
- ;; Otherwise, show the preview.
- (completion-preview--show))
- (completion-preview-active-mode -1)))
+ (let ((internal-p (or completion-preview--inhibit-update-p
+ (memq this-command
+ completion-preview--internal-commands))))
+ (setq completion-preview--inhibit-update-p nil)
+
+ ;; If we're called after a command that itself updates the
+ ;; preview, don't do anything.
+ (unless internal-p
+ (if (and (completion-preview-require-certain-commands)
+ (completion-preview-require-minimum-symbol-length))
+ (completion-preview--show)
+ (completion-preview-active-mode -1)))))
(defun completion-preview-insert ()
"Insert the completion candidate that the preview is showing."
@@ -347,16 +396,84 @@ completion-preview-insert
(let* ((pre (completion-preview--get 'completion-preview-base))
(end (completion-preview--get 'completion-preview-end))
(ind (completion-preview--get 'completion-preview-index))
- (all (completion-preview--get 'completion-preview-cands))
- (efn (completion-preview--get 'completion-preview-exit-fn))
+ (all (completion-preview--get 'completion-preview-suffixes))
+ (com (completion-preview--get 'completion-preview-common))
+ (efn (plist-get (completion-preview--get 'completion-preview-props)
+ :exit-function))
(aft (completion-preview--get 'after-string))
- (str (concat pre (nth ind all))))
+ (str (concat pre com (nth ind all))))
(completion-preview-active-mode -1)
(goto-char end)
(insert (substring-no-properties aft))
(when (functionp efn) (funcall efn str 'finished)))
(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 ()
"Cycle the candidate that the preview is showing to the previous suggestion."
(interactive)
@@ -372,18 +489,29 @@ completion-preview-next-candidate
(when completion-preview-active-mode
(let* ((beg (completion-preview--get 'completion-preview-beg))
(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))
(len (length all))
(new (mod (+ cur direction) len))
- (str (nth new all)))
- (while (or (<= (+ beg (length str)) end)
- (not (string-prefix-p (buffer-substring beg end) str)))
- (setq new (mod (+ new direction) len) str (nth new all)))
- (let ((aft (propertize (substring str (- end beg))
- 'face (if (< 1 len)
+ (suf (nth new all))
+ (lencom (length com)))
+ ;; Skip suffixes that are no longer applicable. This may happen
+ ;; when the user continues typing and immediately runs this
+ ;; command, before the completion backend returns an updated set
+ ;; 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)
+ `(face ,(if (cdr all)
'completion-preview
- 'completion-preview-exact)
+ 'completion-preview-exact))
+ suf)
+ (let ((aft (propertize (substring (concat com suf) (- end beg))
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map)))
(add-text-properties 0 1 '(cursor 1) aft)
@@ -398,6 +526,7 @@ completion-preview--active-p
(buffer-local-value 'completion-preview-active-mode buffer))
(dolist (cmd '(completion-preview-insert
+ completion-preview-complete
completion-preview-prev-candidate
completion-preview-next-candidate))
(put cmd 'completion-predicate #'completion-preview--active-p))
@@ -409,11 +538,12 @@ completion-preview-mode
This mode automatically shows and updates the completion preview
according to the text around point.
\\<completion-preview-active-mode-map>\
-When the preview is visible, \\[completion-preview-insert]
-accepts the completion suggestion,
+When the preview is visible, \\[completion-preview-insert] accepts the
+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 suggestion, and \\[completion-preview-prev-candidate]
-cycles backward."
+completion suggestion, and \\[completion-preview-prev-candidate] cycles
+backward."
:lighter " CP"
(if completion-preview-mode
(add-hook 'post-command-hook #'completion-preview--post-command nil t)
diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el
index 5b2c28bd3dd..7d358d07519 100644
--- a/test/lisp/completion-preview-tests.el
+++ b/test/lisp/completion-preview-tests.el
@@ -27,23 +27,25 @@ completion-preview-tests--capf
(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)
+(defun completion-preview-tests--check-preview
+ (string &optional beg-face end-face)
"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.
+BEG-FACE and END-FACE say which faces the beginning and end of STRING
+should have, respectively. Both BEG-FACE and END-FACE default to
+`completion-preview'.
If STRING is nil, check that there is no completion preview
instead."
(if (not string)
- (should (not completion-preview--overlay))
+ (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
+ (or beg-face 'completion-preview)))
+ (should (eq (get-text-property (1- (length after-string)) 'face after-string)
+ (or end-face
'completion-preview))))))
(ert-deftest completion-preview ()
@@ -57,7 +59,9 @@ completion-preview
(completion-preview--post-command))
;; Exact match
- (completion-preview-tests--check-preview "barbaz" 'exact)
+ (completion-preview-tests--check-preview "barbaz"
+ 'completion-preview-exact
+ 'completion-preview-exact)
(insert "v")
(let ((this-command 'self-insert-command))
@@ -71,7 +75,9 @@ completion-preview
(completion-preview--post-command))
;; 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 ()
"Test Completion Preview mode with multiple matching candidates."
@@ -84,12 +90,12 @@ completion-preview-multiple-matches
(completion-preview--post-command))
;; 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)
;; Next match
- (completion-preview-tests--check-preview "baz")))
+ (completion-preview-tests--check-preview "baz" 'completion-preview-common)))
(ert-deftest completion-preview-exact-match-only ()
"Test `completion-preview-exact-match-only'."
@@ -111,7 +117,9 @@ completion-preview-exact-match-only
(completion-preview--post-command))
;; 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 ()
"Test Completion Preview mode with capfs that return a function."
@@ -124,7 +132,7 @@ completion-preview-function-capfs
(insert "foo")
(let ((this-command 'self-insert-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 ()
"Test Completion Preview mode with non-exclusive capfs."
@@ -140,11 +148,13 @@ completion-preview-non-exclusive-capfs
(insert "foo")
(let ((this-command 'self-insert-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)
(let ((this-command 'self-insert-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 ()
"Test updating the face in completion preview when match is no longer exact."
@@ -160,7 +170,9 @@ completion-preview-face-updates
(insert "b")
(let ((this-command 'self-insert-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)
(let ((this-command 'delete-backward-char))
(completion-preview--post-command))
@@ -173,13 +185,15 @@ completion-preview-capf-errors
(with-temp-buffer
(setq-local completion-at-point-functions
(list
- (lambda () (user-error "bad"))
+ (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--check-preview "barbaz"
+ 'completion-preview-exact
+ 'completion-preview-exact)))
(ert-deftest completion-preview-mid-symbol-cycle ()
"Test cycling the completion preview with point at the middle of a symbol."
@@ -196,4 +210,101 @@ completion-preview-mid-symbol-cycle
(completion-preview-next-candidate 1)
(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
--
2.44.0
^ permalink raw reply related [flat|nested] 5+ messages in thread
* bug#70381: [PATCH] New command 'completion-preview-complete'
2024-04-14 11:21 bug#70381: [PATCH] New command 'completion-preview-complete' Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
@ 2024-04-14 12:01 ` Eli Zaretskii
2024-04-14 14:05 ` Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
0 siblings, 1 reply; 5+ messages in thread
From: Eli Zaretskii @ 2024-04-14 12:01 UTC (permalink / raw)
To: Eshel Yaron; +Cc: 70381, spacibba
> Cc: Ergus <spacibba@aol.com>
> Date: Sun, 14 Apr 2024 13:21:54 +0200
> From: Eshel Yaron via "Bug reports for GNU Emacs,
> the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>
>
> Following a recent discussion on emacs-devel[0], this patch adds a new
> command for Completion Preview mode that completes the symbol at point up
> to the longest common prefix of all completion candidates. This patch
> also adds a visual indication for the longest common prefix when showing
> it as part of the completion preview, so the user can tell how far the new
> 'completion-preview-complete' will complete before invoking this command.
> For example, if the symbol at point is "foo", and the completion
> candidates are "foobar" and "foobaz", then the preview shows "bar" with
> the common prefix "ba" highlighted in face 'completion-preview-common'.
Thanks.
> * 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): Distinguish from 'c-p-common'.
> (completion-preview-complete): New command. ^^^^^^^^^^
> (completion-preview-active-mode-map): Bind it.
> (completion-preview-mode): Mention it in docstring.
> (completion-preview-commands): Add 'c-p-complete'.
^^^^^^^^^^^^
Please don't abbreviate symbols in the log entries. Those are
frequently used to search for changes of functions/variables, and such
abbreviations defeat those searches.
If you are annoyed by the need to type long strings, I usually find
M-/ instrumental in reducing that annoyance considerably.
> +(defface completion-preview-common
> '((((supports :underline t))
> :underline t :inherit completion-preview)
> (((supports :weight bold))
> :weight bold :inherit completion-preview)
> (t :background "gray"))
> - "Face for exact completion preview overlay."
> + "Face for completions longest common prefix in the completion preview."
^^^^^^^^^^^
This word is redundant here. I'd replace it with "the".
> +(defvar-local completion-preview--inhibit-update-p nil
> + "Whether to inhibit updateing the completion preview following this command.")
^^^^^^^^^
"updating"
> + (set-text-properties 0 (length suffix)
> + `(face ,(if (cdr suffixes)
> + 'completion-preview
> + 'completion-preview-exact))
> + suffix)
> + (set-text-properties 0 (length common)
> + `(face ,(if (cdr suffixes)
> + 'completion-preview-common
> + 'completion-preview-exact))
> + common)
Is the use of back-ticks really necessary here?
> + (set-text-properties 0 (length suffix)
> + `(face ,(if (cdr sufs)
> + 'completion-preview
> + 'completion-preview-exact))
> + suffix)
Likewise here (and in few other places).
^ permalink raw reply [flat|nested] 5+ messages in thread
* bug#70381: [PATCH] New command 'completion-preview-complete'
2024-04-14 12:01 ` Eli Zaretskii
@ 2024-04-14 14:05 ` Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-04-18 10:49 ` Eli Zaretskii
0 siblings, 1 reply; 5+ messages in thread
From: Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors @ 2024-04-14 14:05 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 70381, spacibba
[-- Attachment #1: Type: text/plain, Size: 3813 bytes --]
Eli Zaretskii <eliz@gnu.org> writes:
>> Cc: Ergus <spacibba@aol.com>
>> Date: Sun, 14 Apr 2024 13:21:54 +0200
>> From: Eshel Yaron via "Bug reports for GNU Emacs,
>> the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>
>>
>> Following a recent discussion on emacs-devel[0], this patch adds a new
>> command for Completion Preview mode that completes the symbol at point up
>> to the longest common prefix of all completion candidates. This patch
>> also adds a visual indication for the longest common prefix when showing
>> it as part of the completion preview, so the user can tell how far the new
>> 'completion-preview-complete' will complete before invoking this command.
>> For example, if the symbol at point is "foo", and the completion
>> candidates are "foobar" and "foobaz", then the preview shows "bar" with
>> the common prefix "ba" highlighted in face 'completion-preview-common'.
>
> Thanks.
>
>> * 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): Distinguish from 'c-p-common'.
>> (completion-preview-complete): New command. ^^^^^^^^^^
>> (completion-preview-active-mode-map): Bind it.
>> (completion-preview-mode): Mention it in docstring.
>> (completion-preview-commands): Add 'c-p-complete'.
> ^^^^^^^^^^^^
> Please don't abbreviate symbols in the log entries. Those are
> frequently used to search for changes of functions/variables, and such
> abbreviations defeat those searches.
All right, fixed in the updated patch below.
> If you are annoyed by the need to type long strings, I usually find
> M-/ instrumental in reducing that annoyance considerably.
>
>> +(defface completion-preview-common
>> '((((supports :underline t))
>> :underline t :inherit completion-preview)
>> (((supports :weight bold))
>> :weight bold :inherit completion-preview)
>> (t :background "gray"))
>> - "Face for exact completion preview overlay."
>> + "Face for completions longest common prefix in the completion preview."
> ^^^^^^^^^^^
> This word is redundant here. I'd replace it with "the".
Done.
>> +(defvar-local completion-preview--inhibit-update-p nil
>> + "Whether to inhibit updateing the completion preview following this command.")
> ^^^^^^^^^
> "updating"
Fixed.
>> + (set-text-properties 0 (length suffix)
>> + `(face ,(if (cdr suffixes)
>> + 'completion-preview
>> + 'completion-preview-exact))
>> + suffix)
>> + (set-text-properties 0 (length common)
>> + `(face ,(if (cdr suffixes)
>> + 'completion-preview-common
>> + 'completion-preview-exact))
>> + common)
>
> Is the use of back-ticks really necessary here?
>
>> + (set-text-properties 0 (length suffix)
>> + `(face ,(if (cdr sufs)
>> + 'completion-preview
>> + 'completion-preview-exact))
>> + suffix)
>
> Likewise here (and in few other places).
Not necessary, no. So I've changed these to regular (list ...) forms.
I kept a couple of other backticks that do make the code clearer IMO.
Thanks for taking a look, here's the updated patch:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: v2-0001-New-command-completion-preview-complete.patch --]
[-- Type: text/x-patch, Size: 36089 bytes --]
From a3e34613e16e56bf4cc1aaebb68835c6ec60febe Mon Sep 17 00:00:00 2001
From: Eshel Yaron <me@eshelyaron.com>
Date: Fri, 12 Apr 2024 22:41:10 +0200
Subject: [PATCH v2] New command 'completion-preview-complete'
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.
---
lisp/completion-preview.el | 282 +++++++++++++++++++-------
test/lisp/completion-preview-tests.el | 147 ++++++++++++--
2 files changed, 335 insertions(+), 94 deletions(-)
diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 4e52aa9b151..8bc8cadc46b 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -39,6 +39,16 @@
;; example, to M-n and M-p in `completion-preview-active-mode-map' to
;; 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
;; non-nil, Completion Preview mode only suggests a completion
;; candidate when its the only possible completion for the (partial)
@@ -73,7 +83,8 @@ completion-preview-commands
insert-char
delete-backward-char
backward-delete-char-untabify
- analyze-text-conversion)
+ analyze-text-conversion
+ completion-preview-complete)
"List of commands that should trigger completion preview."
:type '(repeat (function :tag "Command" :value self-insert-command))
:version "30.1")
@@ -104,16 +115,22 @@ completion-preview-sort-function
(defface completion-preview
'((t :inherit shadow))
- "Face for completion preview overlay."
+ "Face for completion candidates in the completion preview overlay."
:version "30.1")
-(defface completion-preview-exact
+(defface completion-preview-common
'((((supports :underline t))
:underline t :inherit completion-preview)
(((supports :weight bold))
:weight bold :inherit completion-preview)
(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")
(defface completion-preview-highlight
@@ -124,6 +141,8 @@ completion-preview-highlight
(defvar-keymap completion-preview-active-mode-map
:doc "Keymap for Completion Preview Active mode."
"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-p" #'completion-preview-prev-candidate
)
@@ -131,8 +150,8 @@ completion-preview-active-mode-map
(defvar-keymap completion-preview--mouse-map
:doc "Keymap for mouse clicks on the completion preview."
"<down-mouse-1>" #'completion-preview-insert
- "C-<down-mouse-1>" #'completion-at-point
- "<down-mouse-2>" #'completion-at-point
+ "C-<down-mouse-1>" #'completion-preview-complete
+ "<down-mouse-2>" #'completion-preview-complete
"<wheel-up>" #'completion-preview-prev-candidate
"<wheel-down>" #'completion-preview-next-candidate)
@@ -147,14 +166,16 @@ completion-preview--internal-commands
Completion Preview mode avoids updating the preview after these commands.")
-(defsubst completion-preview--internal-command-p ()
- "Return non-nil if `this-command' manipulates the completion preview."
- (memq this-command completion-preview--internal-commands))
+(defvar-local completion-preview--inhibit-update-p nil
+ "Whether to inhibit updating the completion preview following this command.")
+
+(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 ()
"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 ()
"Check if the length of symbol at point is at least above a certain threshold.
@@ -167,7 +188,8 @@ completion-preview-hide
"Hide the completion preview."
(when 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)
"Make preview overlay showing STRING at POS, or move existing preview there."
@@ -175,13 +197,9 @@ completion-preview--make-overlay
(move-overlay completion-preview--overlay pos pos)
(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)
- (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))
+ (add-text-properties 0 1 '(cursor 1) string)
+ (overlay-put completion-preview--overlay 'after-string string)
+ completion-preview--overlay)
(defsubst completion-preview--get (prop)
"Return property PROP of the completion preview overlay."
@@ -221,17 +239,25 @@ completion-preview--try-table
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 BASE EXIT-FN) where PREVIEW is the text to
-show in the completion preview, ALL is the list of all matching
-completion candidates, BASE is a common prefix that TABLE elided
-from the start of each candidate, 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."
+If TABLE contains a matching candidate, return a list
+\(BASE COMMON SUFFIXES) where BASE is a prefix of the text
+between BEG and END that TABLE elided from the start of each candidate,
+COMMON is the longest common prefix of all matching candidates,
+SUFFIXES is a list of different suffixes that together with COMMON yield
+the matching candidates. If TABLE does not contain matching
+candidates or if there are multiple matching completions and
+`completion-preview-exact-match-only' is 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))
- (exit-fn (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)
@@ -250,16 +276,16 @@ completion-preview--try-table
(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)
- 'mouse-face 'completion-preview-highlight
- 'keymap completion-preview--mouse-map)
- (+ beg base) end sorted
- (substring string 0 base) exit-fn))))))
+ (delete prefix (all-completions prefix all))))
+ (common (try-completion prefix sorted))
+ (lencom (length common))
+ (suffixes sorted))
+ (unless (and (cdr suffixes) completion-preview-exact-match-only)
+ ;; Remove the common prefix from each candidate.
+ (while sorted
+ (setcar sorted (substring (car sorted) lencom))
+ (setq sorted (cdr sorted)))
+ (list (substring string 0 base) common suffixes))))))
(defun completion-preview--capf-wrapper (capf)
"Translate return value of CAPF to properties for completion preview overlay."
@@ -267,25 +293,41 @@ completion-preview--capf-wrapper
(and (consp res)
(not (functionp 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))
;; Return non-nil to exclude other capfs.
'(nil)))))))
(defun completion-preview--update ()
"Update completion preview."
- (seq-let (preview beg end all base exit-fn)
+ (seq-let (beg end props base common suffixes)
(run-hook-wrapped
'completion-at-point-functions
#'completion-preview--capf-wrapper)
- (when preview
- (let ((ov (completion-preview--make-overlay end preview)))
+ (when-let ((suffix (car suffixes)))
+ (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-end end)
(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-exit-fn exit-fn)
+ (overlay-put ov 'completion-preview-props props)
(completion-preview-active-mode)))))
(defun completion-preview--show ()
@@ -308,17 +350,22 @@ completion-preview--show
;; flicker, even with slow completion backends.
(let* ((beg (completion-preview--get 'completion-preview-beg))
(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))
- (cand (nth index cands))
- (after (completion-preview--get 'after-string))
- (face (get-text-property 0 'face after)))
+ (common (completion-preview--get 'completion-preview-common))
+ (suffix (nth index sufs))
+ (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))))
(string-prefix-p (buffer-substring beg end) cand))
;; The previous preview is still applicable, update it.
(overlay-put (completion-preview--make-overlay
end (propertize (substring cand (- end beg))
- 'face face
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map))
'completion-preview-end end)
@@ -329,16 +376,18 @@ completion-preview--show
(defun completion-preview--post-command ()
"Create, update or delete completion preview post last command."
- (if (and (completion-preview-require-certain-commands)
- (completion-preview-require-minimum-symbol-length))
- ;; We should show the preview.
- (or
- ;; If we're called after a command that itself updates the
- ;; preview, don't do anything.
- (completion-preview--internal-command-p)
- ;; Otherwise, show the preview.
- (completion-preview--show))
- (completion-preview-active-mode -1)))
+ (let ((internal-p (or completion-preview--inhibit-update-p
+ (memq this-command
+ completion-preview--internal-commands))))
+ (setq completion-preview--inhibit-update-p nil)
+
+ ;; If we're called after a command that itself updates the
+ ;; preview, don't do anything.
+ (unless internal-p
+ (if (and (completion-preview-require-certain-commands)
+ (completion-preview-require-minimum-symbol-length))
+ (completion-preview--show)
+ (completion-preview-active-mode -1)))))
(defun completion-preview-insert ()
"Insert the completion candidate that the preview is showing."
@@ -347,16 +396,84 @@ completion-preview-insert
(let* ((pre (completion-preview--get 'completion-preview-base))
(end (completion-preview--get 'completion-preview-end))
(ind (completion-preview--get 'completion-preview-index))
- (all (completion-preview--get 'completion-preview-cands))
- (efn (completion-preview--get 'completion-preview-exit-fn))
+ (all (completion-preview--get 'completion-preview-suffixes))
+ (com (completion-preview--get 'completion-preview-common))
+ (efn (plist-get (completion-preview--get 'completion-preview-props)
+ :exit-function))
(aft (completion-preview--get 'after-string))
- (str (concat pre (nth ind all))))
+ (str (concat pre com (nth ind all))))
(completion-preview-active-mode -1)
(goto-char end)
(insert (substring-no-properties aft))
(when (functionp efn) (funcall efn str 'finished)))
(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 ()
"Cycle the candidate that the preview is showing to the previous suggestion."
(interactive)
@@ -372,18 +489,29 @@ completion-preview-next-candidate
(when completion-preview-active-mode
(let* ((beg (completion-preview--get 'completion-preview-beg))
(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))
(len (length all))
(new (mod (+ cur direction) len))
- (str (nth new all)))
- (while (or (<= (+ beg (length str)) end)
- (not (string-prefix-p (buffer-substring beg end) str)))
- (setq new (mod (+ new direction) len) str (nth new all)))
- (let ((aft (propertize (substring str (- end beg))
- 'face (if (< 1 len)
- 'completion-preview
- 'completion-preview-exact)
+ (suf (nth new all))
+ (lencom (length com)))
+ ;; Skip suffixes that are no longer applicable. This may happen
+ ;; when the user continues typing and immediately runs this
+ ;; command, before the completion backend returns an updated set
+ ;; 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-exact))
+ suf)
+ (let ((aft (propertize (substring (concat com suf) (- end beg))
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map)))
(add-text-properties 0 1 '(cursor 1) aft)
@@ -398,6 +526,7 @@ completion-preview--active-p
(buffer-local-value 'completion-preview-active-mode buffer))
(dolist (cmd '(completion-preview-insert
+ completion-preview-complete
completion-preview-prev-candidate
completion-preview-next-candidate))
(put cmd 'completion-predicate #'completion-preview--active-p))
@@ -409,11 +538,12 @@ completion-preview-mode
This mode automatically shows and updates the completion preview
according to the text around point.
\\<completion-preview-active-mode-map>\
-When the preview is visible, \\[completion-preview-insert]
-accepts the completion suggestion,
+When the preview is visible, \\[completion-preview-insert] accepts the
+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 suggestion, and \\[completion-preview-prev-candidate]
-cycles backward."
+completion suggestion, and \\[completion-preview-prev-candidate] cycles
+backward."
:lighter " CP"
(if completion-preview-mode
(add-hook 'post-command-hook #'completion-preview--post-command nil t)
diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el
index 5b2c28bd3dd..7d358d07519 100644
--- a/test/lisp/completion-preview-tests.el
+++ b/test/lisp/completion-preview-tests.el
@@ -27,23 +27,25 @@ completion-preview-tests--capf
(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)
+(defun completion-preview-tests--check-preview
+ (string &optional beg-face end-face)
"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.
+BEG-FACE and END-FACE say which faces the beginning and end of STRING
+should have, respectively. Both BEG-FACE and END-FACE default to
+`completion-preview'.
If STRING is nil, check that there is no completion preview
instead."
(if (not string)
- (should (not completion-preview--overlay))
+ (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
+ (or beg-face 'completion-preview)))
+ (should (eq (get-text-property (1- (length after-string)) 'face after-string)
+ (or end-face
'completion-preview))))))
(ert-deftest completion-preview ()
@@ -57,7 +59,9 @@ completion-preview
(completion-preview--post-command))
;; Exact match
- (completion-preview-tests--check-preview "barbaz" 'exact)
+ (completion-preview-tests--check-preview "barbaz"
+ 'completion-preview-exact
+ 'completion-preview-exact)
(insert "v")
(let ((this-command 'self-insert-command))
@@ -71,7 +75,9 @@ completion-preview
(completion-preview--post-command))
;; 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 ()
"Test Completion Preview mode with multiple matching candidates."
@@ -84,12 +90,12 @@ completion-preview-multiple-matches
(completion-preview--post-command))
;; 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)
;; Next match
- (completion-preview-tests--check-preview "baz")))
+ (completion-preview-tests--check-preview "baz" 'completion-preview-common)))
(ert-deftest completion-preview-exact-match-only ()
"Test `completion-preview-exact-match-only'."
@@ -111,7 +117,9 @@ completion-preview-exact-match-only
(completion-preview--post-command))
;; 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 ()
"Test Completion Preview mode with capfs that return a function."
@@ -124,7 +132,7 @@ completion-preview-function-capfs
(insert "foo")
(let ((this-command 'self-insert-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 ()
"Test Completion Preview mode with non-exclusive capfs."
@@ -140,11 +148,13 @@ completion-preview-non-exclusive-capfs
(insert "foo")
(let ((this-command 'self-insert-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)
(let ((this-command 'self-insert-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 ()
"Test updating the face in completion preview when match is no longer exact."
@@ -160,7 +170,9 @@ completion-preview-face-updates
(insert "b")
(let ((this-command 'self-insert-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)
(let ((this-command 'delete-backward-char))
(completion-preview--post-command))
@@ -173,13 +185,15 @@ completion-preview-capf-errors
(with-temp-buffer
(setq-local completion-at-point-functions
(list
- (lambda () (user-error "bad"))
+ (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--check-preview "barbaz"
+ 'completion-preview-exact
+ 'completion-preview-exact)))
(ert-deftest completion-preview-mid-symbol-cycle ()
"Test cycling the completion preview with point at the middle of a symbol."
@@ -196,4 +210,101 @@ completion-preview-mid-symbol-cycle
(completion-preview-next-candidate 1)
(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
--
2.44.0
^ permalink raw reply related [flat|nested] 5+ messages in thread
* bug#70381: [PATCH] New command 'completion-preview-complete'
2024-04-14 14:05 ` Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
@ 2024-04-18 10:49 ` Eli Zaretskii
2024-04-20 11:36 ` Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
0 siblings, 1 reply; 5+ messages in thread
From: Eli Zaretskii @ 2024-04-18 10:49 UTC (permalink / raw)
To: Eshel Yaron; +Cc: 70381, spacibba
> From: Eshel Yaron <me@eshelyaron.com>
> Cc: 70381@debbugs.gnu.org, spacibba@aol.com
> Date: Sun, 14 Apr 2024 16:05:20 +0200
>
> Thanks for taking a look, here's the updated patch:
LGTM, feel free to install.
^ permalink raw reply [flat|nested] 5+ messages in thread
* bug#70381: [PATCH] New command 'completion-preview-complete'
2024-04-18 10:49 ` Eli Zaretskii
@ 2024-04-20 11:36 ` Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
0 siblings, 0 replies; 5+ messages in thread
From: Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors @ 2024-04-20 11:36 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: 70381, spacibba
close 70381 30.1
quit
Eli Zaretskii <eliz@gnu.org> writes:
>> From: Eshel Yaron <me@eshelyaron.com>
>> Cc: 70381@debbugs.gnu.org, spacibba@aol.com
>> Date: Sun, 14 Apr 2024 16:05:20 +0200
>>
>> Thanks for taking a look, here's the updated patch:
>
> LGTM, feel free to install.
Thanks, pushed to master, and closing the bug.
Ergus, if you get a chance to try out these changes, I'd love to get
your feedback.
Best,
Eshel
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2024-04-20 11:36 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-04-14 11:21 bug#70381: [PATCH] New command 'completion-preview-complete' Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-04-14 12:01 ` Eli Zaretskii
2024-04-14 14:05 ` Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-04-18 10:49 ` Eli Zaretskii
2024-04-20 11:36 ` Eshel Yaron via Bug reports for GNU Emacs, the Swiss army knife of text editors
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.