From f48c4d2a31ad43b049c0a657a1ed3a324b2a7ced Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Wed, 26 Jun 2024 11:06:52 +0200 Subject: [PATCH] Minor improvements to new Completion Preview commands * lisp/completion-preview.el (Commentary): Mention `completion-preview-partial-insert' and elaborate about `completion-preview-insert-sexp'. (completion-preview--barf-if-no-preview): New function. (completion-preview-insert, completion-preview-complete): Use it. (completion-preview-partial-insert): Rename arg to FUN; only compute (+ end (length aft)) once; bind 'deactivate-mark' to nil while inserting/deleting to allow commands that use this function to work as expected with 'shift-select-mode'; improve behavior when called with point not at the start of the completion preview overlay (e.g. when point is in the middle of a multi-word symbol and this function is called via 'completion-preview-insert-word'); add the base part of the completion candidate to when calling exit-function. (completion-preview-insert-word): Improve docsting, rename argument ARG to N. (completion-preview-insert-sexp): Likewise, and also remove second argument INTERACTIVE. (completion-preview--active-p): Rename to... (completion-preview-active-p): ...this. Make this function public so users can leverage it for their own commands. Extend docstring to explain how to do that. * test/lisp/completion-preview-tests.el (completion-preview-insert-calls-exit-function) (completion-preview-insert-word): Break long lines. (completion-preview-insert-sexp) (completion-preview-insert-nonsubword) (completion-preview-insert-subword): Fix docstrings. (completion-preview-insert-mid-symbol): New test. (cherry picked from commit 9cb2a2040888c28587bed2b0902d9da90720f9a0) --- lisp/completion-preview.el | 184 +++++++++++++++----------- test/lisp/completion-preview-tests.el | 50 ++++++- 2 files changed, 148 insertions(+), 86 deletions(-) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index f846a649e82..2a0d193e6f6 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -55,9 +55,22 @@ ;; This command is not bound by default, but you may want to bind it to ;; M-f (or remap `forward-word') in `completion-preview-active-mode-map' ;; since it's very much like a `forward-word' that also moves "into" the -;; completion preview. A similar command, -;; `completion-preview-insert-sexp', exists for the `forward-sexp' -;; command. +;; completion preview. To define your own command that inserts part of +;; a completion candidate by moving "into" the completion preview, use +;; the function `completion-preview-partial-insert'. For example, you +;; can define a command that completes exactly one symbol as follows: +;; +;; (defun my-completion-preview-insert-symbol () +;; (interactive) +;; (completion-preview-partial-insert #'forward-symbol 1)) +;; +;; Similarly to `completion-preview-insert-word', the command +;; `completion-preview-insert-sexp' lets you complete by one or more +;; balanced expressions. The definition of this command is very similar +;; to the simple example above, expect it uses `forward-sexp' rather +;; than `forward-symbol'. This command can be useful when you're using +;; Completion Preview mode with long, complex completion candidates, +;; such as entire shell commands from the shell history. ;; ;; Completion Preview mode can change the cursor shape while displaying ;; the preview right after point. By default, it uses a vertical bar @@ -525,88 +538,98 @@ point, otherwise hide it." (completion-preview--show) (completion-preview-active-mode -1))))) +(defun completion-preview--barf-if-no-preview () + "Signal a `user-error' if completion preview is not active." + (unless completion-preview-active-mode + (user-error "No current completion preview"))) + (defun completion-preview-insert () "Insert the completion candidate that the preview is showing." (interactive) - (if completion-preview-active-mode + (completion-preview--barf-if-no-preview) + (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-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 com (nth ind all)))) + (completion-preview-active-mode -1) + (goto-char end) + (insert (substring-no-properties aft)) + (when (functionp efn) (funcall efn str 'finished)))) + +(defun completion-preview-partial-insert (fun &rest args) + "Insert part of the current completion preview candidate. + +This function calls FUN with arguments ARGS, after temporarily inserting +the entire current completion preview candidate. FUN should move point: +if it moves point forward into the completion text, this function +inserts the prefix of the completion candidate up to that point. +Beyond moving point, FUN should not modify the current buffer." + (completion-preview--barf-if-no-preview) + (let* ((end (completion-preview--get 'completion-preview-end)) + (aft (completion-preview--get 'after-string)) + (eoc (+ end (length aft)))) + ;; Partially insert current completion candidate. + (atomic-change-group + (let ((change-group (prepare-change-group)) + ;; Keep region active, if it is already. This allows + ;; commands such as `completion-preview-insert-word' to + ;; interact correctly with `shift-select-mode'. + (deactivate-mark nil)) + (save-excursion + (goto-char end) + ;; Temporarily insert the full completion candidate. + (insert (substring-no-properties aft))) + ;; Set point to the end of the prefix that we want to keep. + (apply fun args) + ;; Delete the rest. + (delete-region (min (max end (point)) eoc) eoc) + ;; Combine into one change group + (undo-amalgamate-change-group change-group))) + ;; Cleanup. + (cond + ;; If we kept the entire completion candidate, call :exit-function. + ((<= eoc (point)) (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-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 com (nth ind all)))) + (efn (plist-get + (completion-preview--get 'completion-preview-props) + :exit-function))) (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"))) + (when (functionp efn) (funcall efn (concat pre com (nth ind all)) + 'finished)))) + ;; If we kept anything, update preview overlay accordingly. + ((< end (point)) + (completion-preview--inhibit-update) + (overlay-put (completion-preview--make-overlay + (point) + (propertize + (substring aft (- (point) end)) + 'mouse-face 'completion-preview-highlight + 'keymap completion-preview--mouse-map)) + 'completion-preview-end (point))) + ;; If we kept nothing, do nothing. + ))) + +(defun completion-preview-insert-word (&optional n) + "Insert the first N words of the current completion preview candidate. + +Interactively, N is the numeric prefix argument, and it defaults to 1." + (interactive "^p") + (completion-preview-partial-insert #'forward-word n)) -(defun completion-preview-partial-insert (function &rest args) - "Insert part of the current completion preview candidate. -This function calls FUN with arguments ARGS, after temporarily inserting -the entire current completion preview candidate. FUN should move point: -if it moves point forward into the completion text, this function -inserts the prefix of the completion candidate up to that point. Beyond -moving point, FUN should not modify the current buffer." - (if completion-preview-active-mode - (let* ((beg (completion-preview--get 'completion-preview-beg)) - (end (completion-preview--get 'completion-preview-end)) - (efn (plist-get (completion-preview--get 'completion-preview-props) - :exit-function)) - (aft (completion-preview--get 'after-string)) - (suf)) - ;; Perform the insertion - (atomic-change-group - (let ((change-group (prepare-change-group))) - ;; Insert full completion - (goto-char end) - (insert (substring-no-properties aft)) - ;; Move forward within the completion - (goto-char end) - (apply function args) - (when (< (point) end) - ;; If the movement function brought us backwards lurch - ;; forward to the original end - (goto-char end)) - ;; Delete. - (when (< (point) (+ end (length aft))) - (delete-region (+ end (length aft)) (point)) - (setq suf (substring aft (- (point) (+ end (length aft))) nil))) - ;; Combine into one change group - (undo-amalgamate-change-group change-group))) - ;; Perform any cleanup actions - (if suf - ;; The movement function has not taken us to the end of the - ;; initial insertion this means that a partial completion - ;; occured. - (progn - (completion-preview--inhibit-update) - ;; If we are not inserting a full completion update the preview - (overlay-put (completion-preview--make-overlay - (point) (propertize suf - 'mouse-face 'completion-preview-highlight - 'keymap completion-preview--mouse-map)) - 'completion-preview-end (point))) - ;; The movement function has taken us to the end of the - ;; completion or past it which signifies a full completion. - (goto-char (+ end (length aft))) - (completion-preview-active-mode -1) - (when (functionp efn) - (funcall efn (buffer-substring-no-properties beg (point)) 'finished)))) - (user-error "No current completion preview"))) +(defun completion-preview-insert-sexp (&optional n) + "Insert the first N s-expressions of the current completion preview candidate. -(defun completion-preview-insert-word (&optional arg) - "Insert the next word of the completion candidate that the preview is showing." +Interactively, N is the numeric prefix argument, and it defaults to 1." (interactive "^p") - (completion-preview-partial-insert #'forward-word arg)) - -(defun completion-preview-insert-sexp (&optional arg interactive) - "Insert the next sexp of the completion candidate that the preview is showing." - (interactive "^p\nd") - (completion-preview-partial-insert #'forward-sexp arg interactive)) + (completion-preview-partial-insert #'forward-sexp n 'interactive)) (defun completion-preview-complete () "Complete up to the longest common prefix of all completion candidates. @@ -617,8 +640,7 @@ 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")) + (completion-preview--barf-if-no-preview) (let* ((beg (completion-preview--get 'completion-preview-beg)) (end (completion-preview--get 'completion-preview-end)) (com (completion-preview--get 'completion-preview-common)) @@ -723,8 +745,12 @@ prefix argument and defaults to 1." (message (format-spec completion-preview-message-format `((?i . ,(1+ new)) (?n . ,len)))))))) -(defun completion-preview--active-p (_symbol buffer) - "Check if the completion preview is currently shown in BUFFER." +(defun completion-preview-active-p (_symbol buffer) + "Check if the completion preview is currently shown in BUFFER. + +The first argument, SYMBOL, is ignored. You can use this function as +the `completion-predicate' property of commands that you define that +should only be available when the completion preview is active." (buffer-local-value 'completion-preview-active-mode buffer)) (dolist (cmd '(completion-preview-insert @@ -733,7 +759,7 @@ prefix argument and defaults to 1." completion-preview-complete completion-preview-prev-candidate completion-preview-next-candidate)) - (put cmd 'completion-predicate #'completion-preview--active-p)) + (put cmd 'completion-predicate #'completion-preview-active-p)) ;;;###autoload (define-minor-mode completion-preview-mode diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el index 6809c7e1320..35b69681ce6 100644 --- a/test/lisp/completion-preview-tests.el +++ b/test/lisp/completion-preview-tests.el @@ -301,7 +301,8 @@ instead." (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "bar-1 2" 'completion-preview-common) + (completion-preview-tests--check-preview "bar-1 2" + 'completion-preview-common) (completion-preview-insert-word) (should (string= (buffer-string) "foobar")) (completion-preview-tests--check-preview "-1 2" 'completion-preview) @@ -309,7 +310,7 @@ instead." (should-not exit-fn-args)))) (ert-deftest completion-preview-insert-nonsubword () - "Test that `completion-preview-insert-word' properly inserts just a word." + "Test that `completion-preview-insert-word' with `subword-mode' off." (let ((exit-fn-called nil) (exit-fn-args nil)) (with-temp-buffer (setq-local completion-at-point-functions @@ -323,7 +324,8 @@ instead." (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "barBar" 'completion-preview-common) + (completion-preview-tests--check-preview "barBar" + 'completion-preview-common) (completion-preview-insert-word) (should (string= (buffer-string) "foobarBar")) (should-not completion-preview--overlay) @@ -331,7 +333,7 @@ instead." (should (equal exit-fn-args '("foobarBar" finished)))))) (ert-deftest completion-preview-insert-subword () - "Test that `completion-preview-insert-word' properly inserts just a word." + "Test that `completion-preview-insert-word' with `subword-mode' on." (let ((exit-fn-called nil) (exit-fn-args nil)) (with-temp-buffer (subword-mode) @@ -346,15 +348,48 @@ instead." (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "barBar" 'completion-preview-common) + (completion-preview-tests--check-preview "barBar" + 'completion-preview-common) (completion-preview-insert-word) (should (string= (buffer-string) "foobar")) (completion-preview-tests--check-preview "Bar" 'completion-preview) (should-not exit-fn-called) (should-not exit-fn-args)))) +(ert-deftest completion-preview-insert-mid-symbol () + "Test `completion-preview-insert-word' when point is in a mulit-word symbol." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("foo-bar-baz-spam")))) + (insert "foo-bar-baz-") + (goto-char 4) + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "spam" + 'completion-preview-exact + 'completion-preview-exact) + (completion-preview-insert-word 2) + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + ;; Moving two words forward should land at the end of baz, without + ;; inserting anything from the completion candidate. + (completion-preview-tests--check-preview "spam" + 'completion-preview-exact + 'completion-preview-exact) + (should (= (point) 12)) + (completion-preview-insert-word -2) + ;; Moving backward shouldn't change anything, either. + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "spam" + 'completion-preview-exact + 'completion-preview-exact) + (should (= (point) 5)))) + (ert-deftest completion-preview-insert-sexp () - "Test that `completion-preview-insert-word' properly inserts just a sexp." + "Test that `completion-preview-insert-sexp' properly inserts just a sexp." (let ((exit-fn-called nil) (exit-fn-args nil)) (with-temp-buffer (setq-local completion-at-point-functions @@ -368,7 +403,8 @@ instead." (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "bar-1 2" 'completion-preview-common) + (completion-preview-tests--check-preview "bar-1 2" + 'completion-preview-common) (completion-preview-insert-sexp) (should (string= (buffer-string) "foobar-1")) (completion-preview-tests--check-preview " 2" 'completion-preview) -- 2.39.2