[nongnu] elpa/with-simulated-input 4c68e02cc1 010/134: Allow evaluating lisp forms while simulating input

[ELPA Syncer]

branch: elpa/with-simulated-input
commit 4c68e02cc1fb0c45addd4ae103e6bd00dbcbd0a1
Author: Ryan C. Thompson <rct@thompsonclan.org>
Commit: Ryan C. Thompson <rct@thompsonclan.org>

    Allow evaluating lisp forms while simulating input
---
 Cask                               |   1 +
 tests/test-with-simulated-input.el |  77 ++++++++++-----
 with-simulated-input.el            | 192 ++++++++++++++++++++++++++++---------
 3 files changed, 198 insertions(+), 72 deletions(-)

diff --git a/Cask b/Cask
index e40b72a0d5..4517876f8a 100644
--- a/Cask
+++ b/Cask
@@ -7,6 +7,7 @@
          "A macro to simulate user input non-interactively.")
 
 (depends-on "seq")
+(depends-on "s")
 
 (development
  (depends-on "buttercup"
diff --git a/tests/test-with-simulated-input.el 
b/tests/test-with-simulated-input.el
index b47e25c070..6524e68a4a 100644
--- a/tests/test-with-simulated-input.el
+++ b/tests/test-with-simulated-input.el
@@ -4,7 +4,10 @@
 (require 'cl-lib)
 (require 'buttercup)
 
-(describe "Basic functionality of `with-simulated-input'"
+;; Needs to be dynamically bound
+(defvar mycollection)
+
+(describe "`with-simulated-input'"
   (it "should work for basic string input"
     (expect
      (with-simulated-input "hello RET"
@@ -35,32 +38,56 @@
        (list (read-string "First word: ")
              (read-string "Second word: ")))
      :to-equal '("hello" "world")))
-  (it "should not allow `C-g' in the input"
+  (it "should allow aborting via C-g in KEYS"
     (expect
-     (lambda ()
-       (with-simulated-input "C-g" (ignore)))
-     :to-throw)))
+     (condition-case nil
+         (with-simulated-input "C-g"
+           (read-string "Enter a string: "))
+       (quit 'caught-quit))
+     :to-be 'caught-quit))
 
-(describe "Using `with-simulated-input' with `completing-read'"
-  :var ((collection '("bluebird" "blueberry" "bluebell" "bluegrass" 
"baseball"))
-        (completing-read-function #'completing-read-default))
-  ;; Unambiguous completion
-  (it "should work with unambiguous tab completion"
-    (expect
-     ;; First TAB completes "blue", 2nd completes "bird"
-     (with-simulated-input "bl TAB bi TAB RET"
-       (completing-read "Choose: " collection))
-     :to-equal "bluebird"))
-  (it "should work with ambiguous tab completion"
-    (expect
-     (with-simulated-input "bl TAB C-j"
-       (completing-read "Choose: " collection))
-     :to-equal "blue"))
-  (it "should fail to exit with ambiguous completion and `require-match'"
-    (expect
-     (lambda ()
+
+  (describe "used with `completing-read'"
+    :var (collection completing-read-function)
+    (before-each
+      (setq mycollection '("bluebird" "blueberry" "bluebell" "bluegrass" 
"baseball")
+            completing-read-function #'completing-read-default))
+    ;; Unambiguous completion
+    (it "should work with unambiguous tab completion"
+      (expect
+       ;; First TAB completes "blue", 2nd completes "bird"
+       (with-simulated-input "bl TAB bi TAB RET"
+         (completing-read "Choose: " mycollection))
+       :to-equal "bluebird"))
+    (it "should work with ambiguous tab completion"
+      (expect
        (with-simulated-input "bl TAB C-j"
-         (completing-read "Choose: " collection nil t)))
-     :to-throw)))
+         (completing-read "Choose: " mycollection))
+       :to-equal "blue"))
+    (it "should fail to exit with ambiguous completion and `require-match'"
+      (expect
+       (lambda ()
+         (with-simulated-input "bl TAB C-j"
+           (completing-read "Choose: " mycollection nil t)))
+       :to-throw)))
+
+  (describe "using lisp forms in KEYS argument of `with-simulated-input'"
+    (it "should allow evaluating arbitrary lisp forms"
+      (expect
+       (with-simulated-input '("hello SPC" (insert "world") "RET")
+         (read-string "Enter a string: "))
+       :to-equal "hello world"))
+    (it "should allow lisp forms to throw errors"
+      (expect
+       (lambda ()
+         (with-simulated-input '("hello SPC" (error "Throwing an error") "RET")
+           (read-string "Enter a string: ")))
+       :to-throw))
+    (it "should not interpret lisp forms once BODY has finished"
+      (expect
+       (with-simulated-input '("hello SPC world RET RET"
+                               (error "Should not reach this error"))
+         (read-string "Enter a string: "))
+       :to-equal "hello world"))))
 
 ;;; test-with-simulated-input.el ends here
diff --git a/with-simulated-input.el b/with-simulated-input.el
index 6a1f917d7b..83c352ff3e 100644
--- a/with-simulated-input.el
+++ b/with-simulated-input.el
@@ -6,7 +6,7 @@
 ;; Author: Ryan C. Thompson
 ;; Created: Thu Jul 20 11:56:23 2017 (-0700)
 ;; Version: 1.0
-;; Package-Requires: ((emacs "24.4") (seq "2.0"))
+;; Package-Requires: ((emacs "24.4") (seq "2.0") (s "0"))
 ;; URL:
 ;; Keywords: lisp, tools, extensions
 
@@ -44,6 +44,91 @@
 
 (require 'cl-lib)
 (require 'seq)
+(require 's)
+
+(cl-defun wsi-key-bound-p (key)
+  "Return non-nil if KEY is bound in any keymap.
+
+This function checks every keymap in `obarray' for a binding for
+KEY, and returns t if it finds and and nil otherwise. Note that
+this checks ALL keymaps, not just currently active ones."
+  (catch 'bound
+  (mapatoms
+   (lambda (sym)
+     (let ((keymap
+            (when (boundp sym)
+              (symbol-value sym))))
+       (when (keymapp keymap)
+         (let ((binding (lookup-key keymap (kbd key))))
+           (when binding
+             (throw 'bound t)))))))
+  (throw 'bound nil)))
+
+(cl-defun wsi-get-unbound-key
+    (&optional (modifiers '("C-M-A-s-H-" "C-M-A-s-" "C-M-A-H-"))
+               (keys "abcdefghijklmnopqrstuvwxyz0123456789"))
+  "Return a key binding that is not bound in any known keymap.
+
+This function will try check every letter from a to z and every
+number from 0 through 9 with several combinations of multiple
+modifiers (i.e. control, meta, alt, super, hyper). For each such
+key combination, it will check for bindings in all known keymaps,
+and return the first combination for which no such bindings
+exist. Thus, it should be safe to bind this key in a new keymap
+without interfering with any existing keymap.
+
+Optional arguments MODIFIERS and KEYS can be used the change the
+search space. MODIFIERS is a list of strings representing
+modifier combinations, e.g.:
+
+    '(\"C-\" \"M-\" \"C-M-\")
+
+for control, meta, or both. KEYS is a string containing all keys
+to check.
+"
+  (declare (advertised-calling-convention (&optional modifiers keys) nil))
+  (when (stringp modifiers)
+    (setq modifiers (list modifiers)))
+  (when (listp keys)
+    (setq keys (apply #'concat keys)))
+  (cl-loop
+   named findkey
+   for modifier in modifiers
+   do (cl-loop
+       for char across keys
+       for bind = (concat modifier (string char))
+       when (not (wsi-key-bound-p bind))
+       do (cl-return-from findkey bind))
+   finally do (error "Could not find an unbound key with the specified 
modifiers")))
+
+(defun wsi-prepare-actions (keys exec-form-keybind)
+  (cl-loop
+   with full-key-sequence = '()
+   with action-list = '()
+   for action in keys
+   if (stringp action)
+   collect action into full-key-sequence
+   else
+   collect action into action-list and
+   collect exec-form-keybind into full-key-sequence
+   finally return
+   (list :keys (s-join " " full-key-sequence)
+         :actions action-list)))
+
+(defvar wsi-action-list nil)
+
+(defun wsi-run-next-action ()
+  "Pop and eval the next element in `wsi-action-list'.
+
+If the action list is empty, run `(keyboard-quit)' instead."
+  (interactive)
+  (condition-case err
+      (if wsi-action-list
+          (let ((next-action (pop wsi-action-list)))
+            ;; (message "Executing `%S'" next-action)
+            (eval next-action))
+        (error "Reached end of `wsi-action-list'."))
+    (error (throw 'wsi-threw-error err))))
 
 ;;;###autoload
 (defmacro with-simulated-input (keys &rest body)
@@ -55,60 +140,73 @@ user input (e.g. via `completing-read'), it will read input
 events from KEYS instead, as if the user had manually typed those
 keys after initiating evaluation of BODY.
 
+KEYS should be a string representing a sequence of key presses,
+in the format understood by `kbd'. In the most common case of
+typing in some text and pressing RET, KEYS would be something
+like `\"hello RET\"'. Note that spaced must be indicated
+explicitly using `SPC', e.g. `\"hello SPC world RET\"'.
+
+KEYS can also be a list. In this case, each element should either
+be a key sequence as described above or an arbitrary lisp form
+that will be evaluated at that point in the input sequence. For
+example, `\"hello RET\"' could also be written as:
+
+    `((insert \"hello\") \"RET\")'
+
+Currently, KEYS cannot contain more than 36 lisp forms.
+
 If BODY tries to read more input events than KEYS provides, an
 error is signalled. This is to ensure that BODY will never block
 waiting for input, since this macro is intended for
 non-interactive use. If BODY does not consume all the input
-events in KEYS, the remaining input events are discarded.
+events in KEYS, the remaining input events in KEYS are discarded,
+and any remaining lisp forms in KEYS are never evaluated.
+
+Any errors generated by any means during the evaluation of BODY
+are propagated normally.
 
 The return value is the last form in BODY, as if it was wrapped
 in `progn'."
   (declare (indent 1))
-  (let ((temp-cmd (cl-gensym "temp-cmd"))
-        (cmd-finished-tag (cl-gensym "cmd-finished"))
-        (canary-sym (cl-gensym "canary")))
-    `(cl-letf*
-         (;; Wrap BODY in a command that evaluates BODY and throws the
-          ;; result with `cmd-finished-tag'.
-          ((symbol-function ',temp-cmd)
-           (lambda ()
-             (interactive)
-             (throw ',cmd-finished-tag (progn ,@body))))
-          ;; Set up the keymap for invoking the temp command
-          (transient-map (make-sparse-keymap))
-          (command-invoke-key-sequence "C-c e")
-          (simulated-key-sequence ,keys)
-          (trailing-C-g-key-sequence
-           ;; We *really* want to trigger `keyboard-quit' if we reach
-           ;; the end of KEYS.
-           "C-g C-g C-g C-g C-g C-g C-g")
-          (full-key-sequence
-           (mapconcat #'identity
-                      (list
-                       command-invoke-key-sequence
-                       simulated-key-sequence
-                       trailing-C-g-key-sequence)
-                      " ")))
-       (when (seq-contains (kbd simulated-key-sequence) (elt (kbd "C-g") 0))
-         (error "KEYS must not include C-g"))
-       ;; Finish setting up the keymap for the temp command
-       (define-key transient-map (kbd command-invoke-key-sequence) ',temp-cmd)
-       (set-transient-map transient-map)
-       ;; Run the command followed by KEYS followed by C-g. The
-       ;; `catch' ensures that the keyboard macro stops executing as
-       ;; soon as BODY has finished evaluating, even if there are more
-       ;; keys to interpret.
-       (let ((result
-              (condition-case err
-                  (catch ',cmd-finished-tag
-                    (execute-kbd-macro (kbd full-key-sequence))
-                    ;; If the above doesn't throw, return the canary
-                    ',canary-sym)
-                ;; On `keyboard-quit', return canary
-                (quit ',canary-sym))))
-         (if (eq result ',canary-sym)
-             (error "Reached end of simulated input while evaluating body")
-           result)))))
+  `(cl-letf*
+       ((next-action-key (wsi-get-unbound-key))
+        (result 'wsi-canary)
+        (thrown-error nil)
+        (body-form
+         '(throw 'wsi-body-finished (progn ,@body)))
+        ;; Ensure KEYS is a list, and put the body form as the first
+        ;; item and `C-g' as the last item
+        (keys (append
+               (list body-form)
+               (if (listp ,keys)
+                   ,keys
+                 (list ,keys))
+               '((throw 'wsi-body-finished 'wsi-canary))))
+        ;; Prepare the list of actions to execute, and the full key
+        ;; sequence to execute them
+        (action-plist (wsi-prepare-actions keys next-action-key))
+        (wsi-action-list (plist-get action-plist :actions))
+        (full-key-sequence
+         (concat (plist-get action-plist :keys)))
+        ;; Set up the temporary keymap
+        (action-map (make-sparse-keymap)))
+     ;; Finish setting up the keymap for the temp command
+     (define-key action-map (kbd next-action-key) 'wsi-run-next-action)
+     (setq
+      thrown-error
+      (catch 'wsi-threw-error
+        (setq
+         result
+         (catch 'wsi-body-finished
+           (let ((overriding-terminal-local-map action-map))
+             (execute-kbd-macro (kbd full-key-sequence)))))
+        ;; If we got here, then no error
+        (throw 'wsi-threw-error nil)))
+     (when thrown-error
+       (signal (car thrown-error) (cdr thrown-error)))
+     (if (eq result 'wsi-canary)
+         (error "Reached end of simulated input while evaluating body")
+       result)))
 
 (provide 'with-simulated-input)