bug#71716: [PATCH] Add new completion-preview-insert-{word, sexp} commands

[Jules Tamagnan <jtamagnan@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 844 bytes --]

Hi Eshel,

I've further tweaked the code to address the second point of
feedback. Looking at it now it seems a bit uglier for the "standard"
insert case so I'd be willing to revert that consolidation. Overall it
seems to work well both in unit tests and in my personal testing. 

In the last message I attached a patch with only my second commit. This
new patch contains of all 3 commits:
  1. The initial change
  2. The change to preserve the prefix and reduce flicker
  3. The change to support different modes and definitions of
     word. This change also includes new tests. It is worth noting that
     this will not work as a user may expect if `forward-word` or
     `forward-sexp` are bound to other functions but hopefully the
     included helper functions can allow users to define these functions
     if they need.

Best,
Jules


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Complete patch consisting of 3 commits --]
[-- Type: text/x-patch, Size: 17624 bytes --]

From d78a9a4209d050dcb2a410610d70840d35b9b722 Mon Sep 17 00:00:00 2001
From: Jules Tamagnan <jtamagnan@gmail.com>
Date: Sat, 22 Jun 2024 00:45:01 -0700
Subject: [PATCH 1/3] Add new completion-preview-insert-{word,sexp} commands

* lisp/completion-preview.el: Add new completion-preview-insert-word and
  completion-preview-insert-sexp commands.
* test/lisp/completion-preview-tests.el: Add tests for new commands.
---
 lisp/completion-preview.el            | 56 +++++++++++++++++++--------
 test/lisp/completion-preview-tests.el | 52 +++++++++++++++++++++++--
 2 files changed, 88 insertions(+), 20 deletions(-)

diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index caebb9d01e3..3a7fa37afe0 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -90,7 +90,9 @@ completion-preview-commands
                                          delete-backward-char
                                          backward-delete-char-untabify
                                          analyze-text-conversion
-                                         completion-preview-complete)
+                                         completion-preview-complete
+                                         completion-preview-insert-word
+                                         completion-preview-insert-sexp)
   "List of commands that should trigger completion preview."
   :type '(repeat (function :tag "Command" :value self-insert-command))
   :version "30.1")
@@ -163,6 +165,8 @@ completion-preview-active-mode-map
   "M-i" #'completion-preview-complete
   ;; "M-n" #'completion-preview-next-candidate
   ;; "M-p" #'completion-preview-prev-candidate
+  ;; "<remap> <forward-word>" #'completion-preview-insert-word
+  ;; "<remap> <forward-sexp>" #'completion-preview-insert-sexp
   )

 (defun completion-preview--ignore ()
@@ -444,24 +448,42 @@ completion-preview--post-command
           (completion-preview--show)
         (completion-preview-active-mode -1)))))

+(defun completion-preview--insert (action)
+  "A helper function to insert part of the completion candidate that the
+preview is showing."
+  (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))
+             (ful (completion-preview--get 'after-string))
+             (aft (with-temp-buffer
+                      (insert ful)
+                      (goto-char (point-min))
+                      (funcall action)
+                      (buffer-substring-no-properties (point-min) (point)))))
+        (completion-preview-active-mode -1)
+        (goto-char end)
+        (insert aft)
+        (when (and (functionp efn) (string= ful aft))
+          ;; If we've inserted a full completion call the exit-function
+          (funcall efn (concat (buffer-substring-no-properties beg end) aft) 'finished)))
+    (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
-      (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)))
-    (user-error "No current completion preview")))
+  (completion-preview--insert #'end-of-buffer))
+
+(defun completion-preview-insert-word ()
+  "Insert the next word of the completion candidate that the preview is showing."
+  (interactive)
+  (completion-preview--insert #'forward-word))
+
+(defun completion-preview-insert-sexp ()
+  "Insert the next sexp of the completion candidate that the preview is showing."
+  (interactive)
+  (completion-preview--insert #'forward-sexp))

 (defun completion-preview-complete ()
   "Complete up to the longest common prefix of all completion candidates.
@@ -583,6 +605,8 @@ completion-preview--active-p
   (buffer-local-value 'completion-preview-active-mode buffer))

 (dolist (cmd '(completion-preview-insert
+               completion-preview-insert-word
+               completion-preview-insert-sexp
                completion-preview-complete
                completion-preview-prev-candidate
                completion-preview-next-candidate))
diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el
index 7d358d07519..dedd135da73 100644
--- a/test/lisp/completion-preview-tests.el
+++ b/test/lisp/completion-preview-tests.el
@@ -292,7 +292,7 @@ completion-preview-insert-calls-exit-function
       (setq-local completion-at-point-functions
                   (list
                    (completion-preview-tests--capf
-                    '("foobar" "foobaz")
+                    '("foobar-1 2" "foobarverylong")
                     :exit-function
                     (lambda (&rest args)
                       (setq exit-fn-called t
@@ -300,11 +300,55 @@ completion-preview-insert-calls-exit-function
       (insert "foo")
       (let ((this-command 'self-insert-command))
         (completion-preview--post-command))
-      (completion-preview-tests--check-preview "bar" 'completion-preview-common)
+      (completion-preview-tests--check-preview "bar-1 2" 'completion-preview-common)
       (completion-preview-insert)
-      (should (string= (buffer-string) "foobar"))
+      (should (string= (buffer-string) "foobar-1 2"))
       (should-not completion-preview--overlay)
       (should exit-fn-called)
-      (should (equal exit-fn-args '("foobar" finished))))))
+      (should (equal exit-fn-args '("foobar-1 2" finished))))))
+
+(ert-deftest completion-preview-insert-word ()
+  "Test that `completion-preview-insert-word' properly inserts just a word."
+  (let ((exit-fn-called nil) (exit-fn-args nil))
+    (with-temp-buffer
+      (setq-local completion-at-point-functions
+                  (list
+                   (completion-preview-tests--capf
+                    '("foobar-1 2" "foobarverylong")
+                    :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-1 2" 'completion-preview-common)
+      (completion-preview-insert-word)
+      (should (string= (buffer-string) "foobar"))
+      (should-not completion-preview--overlay)
+      (should-not exit-fn-called)
+      (should-not exit-fn-args))))
+
+(ert-deftest completion-preview-insert-sexp ()
+  "Test that `completion-preview-insert-word' properly inserts just a sexp."
+  (let ((exit-fn-called nil) (exit-fn-args nil))
+    (with-temp-buffer
+      (setq-local completion-at-point-functions
+                  (list
+                   (completion-preview-tests--capf
+                    '("foobar-1 2" "foobarverylong")
+                    :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-1 2" 'completion-preview-common)
+      (completion-preview-insert-sexp)
+      (should (string= (buffer-string) "foobar-1"))
+      (should-not completion-preview--overlay)
+      (should-not exit-fn-called)
+      (should-not exit-fn-args))))

 ;;; completion-preview-tests.el ends here
--
2.45.1


From 1bbcc10c5b23d63dc8454113403c2d834a69d803 Mon Sep 17 00:00:00 2001
From: Jules Tamagnan <jtamagnan@gmail.com>
Date: Sat, 22 Jun 2024 11:40:09 -0700
Subject: [PATCH 2/3] [Cont] Add new completion-preview-insert-{word,sexp}
 commands

---
 lisp/completion-preview.el            | 37 ++++++++++++++++++++-------
 test/lisp/completion-preview-tests.el |  4 +--
 2 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 3a7fa37afe0..637778caadb 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -456,18 +456,37 @@ completion-preview--insert
              (end (completion-preview--get 'completion-preview-end))
              (efn (plist-get (completion-preview--get 'completion-preview-props)
                              :exit-function))
-             (ful (completion-preview--get 'after-string))
-             (aft (with-temp-buffer
-                      (insert ful)
+             (aft (completion-preview--get 'after-string))
+             (ful (with-temp-buffer
+                      (insert aft)
                       (goto-char (point-min))
                       (funcall action)
-                      (buffer-substring-no-properties (point-min) (point)))))
-        (completion-preview-active-mode -1)
+                      (cons (buffer-substring-no-properties (point-min) (point))
+                            (buffer-substring (point) (point-max)))))
+             (ins (car ful))
+             (suf (cdr ful)))
+        ;; If the completion is a full completion (there is no suffix)
+        ;; deactivate the preview
+        (when (string-empty-p suf)
+          (completion-preview-active-mode -1))
+
+        ;; Insert the new text
         (goto-char end)
-        (insert aft)
-        (when (and (functionp efn) (string= ful aft))
-          ;; If we've inserted a full completion call the exit-function
-          (funcall efn (concat (buffer-substring-no-properties beg end) aft) 'finished)))
+        (insert ins)
+
+        ;; If we are not inserting a full completion update the preview
+        (when (not (string-empty-p suf))
+          (let ((pos (point)))
+            (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)))
+
+        ;; If we've inserted a full completion call the exit-function
+        (when (and (functionp efn) (string-empty-p suf))
+          (funcall efn (concat (buffer-substring-no-properties beg end) ins) 'finished)))
     (user-error "No current completion preview")))

 (defun completion-preview-insert ()
diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el
index dedd135da73..54ba566ad3c 100644
--- a/test/lisp/completion-preview-tests.el
+++ b/test/lisp/completion-preview-tests.el
@@ -325,7 +325,7 @@ completion-preview-insert-word
       (completion-preview-tests--check-preview "bar-1 2" 'completion-preview-common)
       (completion-preview-insert-word)
       (should (string= (buffer-string) "foobar"))
-      (should-not completion-preview--overlay)
+      (completion-preview-tests--check-preview "-1 2" 'completion-preview)
       (should-not exit-fn-called)
       (should-not exit-fn-args))))

@@ -347,7 +347,7 @@ completion-preview-insert-sexp
       (completion-preview-tests--check-preview "bar-1 2" 'completion-preview-common)
       (completion-preview-insert-sexp)
       (should (string= (buffer-string) "foobar-1"))
-      (should-not completion-preview--overlay)
+      (completion-preview-tests--check-preview " 2" 'completion-preview)
       (should-not exit-fn-called)
       (should-not exit-fn-args))))

--
2.45.1


From 2c8ce27276405d4f541527768940a7847a6d9050 Mon Sep 17 00:00:00 2001
From: Jules Tamagnan <jtamagnan@gmail.com>
Date: Sat, 22 Jun 2024 12:51:35 -0700
Subject: [PATCH 3/3] [Cont 2] Add new completion-preview-insert-{word,sexp}
 commands

---
 lisp/completion-preview.el            | 27 +++++++++++-----
 test/lisp/completion-preview-tests.el | 45 +++++++++++++++++++++++++++
 2 files changed, 65 insertions(+), 7 deletions(-)

diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 637778caadb..4071240df81 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -448,7 +448,25 @@ completion-preview--post-command
           (completion-preview--show)
         (completion-preview-active-mode -1)))))

-(defun completion-preview--insert (action)
+(defun completion-preview--determine-substring (command string)
+  "A helper function to determine what parts of a STRING come before and
+after the point when a certain COMMAND has been performed on that STRING"
+  ;; Determine the parent buffer
+  (let ((parent-buffer (current-buffer)))
+    (with-temp-buffer
+      ;; Certain locally set variables can affect common movement
+      ;; commands such as `forward-word'; determine their values from
+      ;; the parent buffer and set them in the temporary buffer.
+      (let ((char-script-table (buffer-local-value 'char-script-table parent-buffer))
+            (find-word-boundary-function-table (buffer-local-value 'find-word-boundary-function-table parent-buffer))
+            (inhibit-field-text-motion (buffer-local-value 'inhibit-field-text-motion parent-buffer)))
+        (insert string)
+        (goto-char (point-min))
+        (funcall command)
+        (cons (buffer-substring-no-properties (point-min) (point))
+              (buffer-substring (point) (point-max)))))))
+
+(defun completion-preview--insert (command)
   "A helper function to insert part of the completion candidate that the
 preview is showing."
   (if completion-preview-active-mode
@@ -457,12 +475,7 @@ completion-preview--insert
              (efn (plist-get (completion-preview--get 'completion-preview-props)
                              :exit-function))
              (aft (completion-preview--get 'after-string))
-             (ful (with-temp-buffer
-                      (insert aft)
-                      (goto-char (point-min))
-                      (funcall action)
-                      (cons (buffer-substring-no-properties (point-min) (point))
-                            (buffer-substring (point) (point-max)))))
+             (ful (completion-preview--determine-substring command aft))
              (ins (car ful))
              (suf (cdr ful)))
         ;; If the completion is a full completion (there is no suffix)
diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el
index 54ba566ad3c..1c8a04c765d 100644
--- a/test/lisp/completion-preview-tests.el
+++ b/test/lisp/completion-preview-tests.el
@@ -329,6 +329,51 @@ completion-preview-insert-word
       (should-not exit-fn-called)
       (should-not exit-fn-args))))

+(ert-deftest completion-preview-insert-nonsubword ()
+  "Test that `completion-preview-insert-word' properly inserts just a word."
+  (let ((exit-fn-called nil) (exit-fn-args nil))
+    (with-temp-buffer
+      (setq-local completion-at-point-functions
+                  (list
+                   (completion-preview-tests--capf
+                    '("foobarBar" "foobarverylong")
+                    :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 "barBar" 'completion-preview-common)
+      (completion-preview-insert-word)
+      (should (string= (buffer-string) "foobarBar"))
+      (should-not completion-preview--overlay)
+      (should exit-fn-called)
+      (should (equal exit-fn-args '("foobarBar" finished))))))
+
+(ert-deftest completion-preview-insert-subword ()
+  "Test that `completion-preview-insert-word' properly inserts just a word."
+  (let ((exit-fn-called nil) (exit-fn-args nil))
+    (with-temp-buffer
+      (subword-mode)
+      (setq-local completion-at-point-functions
+                  (list
+                   (completion-preview-tests--capf
+                    '("foobarBar" "foobarverylong")
+                    :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 "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-sexp ()
   "Test that `completion-preview-insert-word' properly inserts just a sexp."
   (let ((exit-fn-called nil) (exit-fn-args nil))
--
2.45.1