basic version of bespoke modal

1 files changed, 315 insertions, 207 deletions

diff --git a/config/emacs/site-lisp/my-modal.el b/config/emacs/site-lisp/my-modal.el
index 1803609..579524f 100644
--- a/config/emacs/site-lisp/my-modal.el
+++ b/config/emacs/site-lisp/my-modal.el
@@ -1,212 +1,320 @@
 ;;; bespoke vish modal -*- lexical-binding: t; -*-
 
 (require 's)
+(require 'dash)
+
+(defun mm/do-nothing () (interactive))
+
+(defmacro mm/compose-command (first cmd then)
+  "Return the name of a new named function that evaluates all of the forms
+in FIRST (a list of forms), calls CMD interactively with no arguments,
+then evaluates all of the forms in THEN. The return value of the named
+function is the return value of CMD."
+  (let* ((prefix (sxhash first))
+         (suffix (sxhash then))
+         (name (make-symbol (format "%s--f/%s--t/%s" cmd prefix suffix))))
+    `(progn
+       (defun ,name ()
+         ,(format "First do %S then run %s then do %S"
+                  first
+                  cmd
+                  then)
+         (interactive)
+         (let ((ret nil))
+           ,@first
+           (setq ret (call-interactively ,cmd))
+           ,@then
+           ret))
+       (quote ,name))))
+
+(defmacro mm/post-effect-enabler (until effect local)
+  "Returns a function that installs a post-command hook that
+runs EFFECT. It will remove itself on the first invocation for which
+UNTIL is false. Note that this final iteration will still trigger
+EFFECT. Note that the command that calls the returned function will NOT
+trigger EFFECT or consult UNTIL."
+  (setq local (eval local))
+  (let ((name (make-symbol
+               (format "post-effect--%s--%s"
+                       (sxhash effect) (sxhash until)))))
+    `(let ((grace-period t))
+       (defun ,name ()
+         ,(format "Run %S. If not %S then remove from post command hook."
+                  effect until)
+         (if grace-period
+             (setq grace-period nil)
+           (progn
+             (unless ,until
+               (remove-hook 'post-command-hook ',name ,local))
+             ,@effect)))
+       (lambda ()
+         (add-hook 'post-command-hook ',name 0 ,local)))))
+
+(defconst mm/moves '(("h" . backward-char)
+                     ("j" . next-line)
+                     ("k" . previous-line)
+                     ("l" . forward-char)
+
+                     ("e" . forward-word)
+                     ("b" . backward-word)
+                     ("E" . forward-sexp)
+                     ("B" . backward-sexp)
+
+                     ("0" . move-beginning-of-line)
+                     ("$" . move-end-of-line)
+
+                     ("[" . beginning-of-defun)
+                     ("]" . end-of-defun)
+                     ("{" . backward-paragraph)
+                     ("}" . forward-paragraph)
+                     ))
+
+(defconst mm/digits '(("1" . digit-argument)
+                      ("2" . digit-argument)
+                      ("3" . digit-argument)
+                      ("4" . digit-argument)
+                      ("5" . digit-argument)
+                      ("6" . digit-argument)
+                      ("7" . digit-argument)
+                      ("8" . digit-argument)
+                      ("9" . digit-argument)
+                      ))
+
+(defconst mm/no-ops `(
+                      ,(kbd "<escape>")
+                      "`" "-" "+"
+                      "q" "w" "r" "t" "\\"
+                      "s" "f" ";" "'"
+                      "z" "n" "," "."
+
+                      "~" "!" "@" "#" "%" "^" "&" "*" "(" ")" "_" "+"
+                      "Q" "W" "R" "T" "Y" "U" "|"
+                      "S" "D" "F" "H" "J" "K" "L" ":" "\"" ,(kbd "<return>")
+                      "Z" "X" "C" "V" "N" "M" "<" ">"
+                      ))
+
+(defvar-local mm/state 'mm/normal-state-mode)
+(defvar mm/all-states '() )
+
+(defmacro mm/transition-state (to)
+  `(lambda ()
+     (interactive)
+     (funcall mm/state -1)
+     (funcall ,to 1)))
+
+(defmacro mm/define-state (name lighter color keymap enable disable)
+  `(progn
+     (define-minor-mode ,name
+       "TODO This is a modal state."
+       :init-value nil
+       :interactive t
+       :lighter ,lighter
+       :keymap ,keymap
+       (if ,name
+           (progn ;; enable logic
+             ,@enable
+             (set-face-background 'cursor ,color)
+             (setq mm/state ',name))
+         (progn ;; disable logic
+           nil ;nonempty?
+           ,@disable)
+         )
+       )
+     (add-to-list 'mm/all-states ',name)
+     )
+  )
 
-
-(defun do-nothing () (interactive))
-
-(defun yank-looks-like-lines ()
-  (s-contains? "
-" (current-kill 0 t)))
-
-(defun paste-after-maybe-lines ()
-  (interactive)
-  (if (yank-looks-like-lines)
-      (progn
-        (move-end-of-line nil)
-        (newline)
-        (yank))
-    (forward-char-unless-eol)
-    (yank)))
-
-(defun paste-before-maybe-lines ()
+;; TODO consider an entry action that indents the line? maybe controlled by a variable?
+(mm/define-state mm/base-state-mode
+                 " <B>"
+                 "turquoise"
+                 `((,(kbd "<escape>") . ,(mm/transition-state 'mm/normal-state-mode)))
+                 nil
+                 nil)
+
+(mm/define-state mm/normal-state-mode
+                 " <N>"
+                 "lime"
+                 `(,@mm/moves
+                   ,@mm/digits
+                   ,@(mapcar (lambda (key) (cons key 'keyboard-quit))
+                             mm/no-ops)
+
+                   ("m" . set-mark-command)
+                   (,(kbd "SPC") . set-mark-command)
+                   ("u" . undo)
+                   ("p" . yank)
+                   ;; mixing vi/emacs meanings of yank
+                   ("y" . ,(mm/transition-state 'mm/yank-state-mode))
+
+                   ("i" . ,(mm/transition-state 'mm/base-state-mode))
+                   ("a" . ,(mm/compose-command ((unless (eq (point) (line-end-position))
+                                                  (forward-char nil)))
+                                               (mm/transition-state 'mm/base-state-mode)
+                                               nil))
+                   ("I" . ,(mm/compose-command ((beginning-of-line-text nil))
+                                               (mm/transition-state 'mm/base-state-mode)
+                                               nil))
+                   ("A" . ,(mm/compose-command ((move-end-of-line nil))
+                                               (mm/transition-state 'mm/base-state-mode)
+                                               nil))
+
+                   ("d" . ,(mm/transition-state 'mm/delete-state-mode))
+                   ("c" . ,(mm/transition-state 'mm/change-state-mode))
+
+                   ("o" . ,(mm/compose-command ((move-end-of-line nil)
+                                                (newline)
+                                                (funcall indent-line-function))
+                                               (mm/transition-state 'mm/base-state-mode)
+                                               nil))
+                   ("O" . ,(mm/compose-command ((move-beginning-of-line nil)
+                                                (open-line 1)
+                                                (funcall indent-line-function))
+                                               (mm/transition-state 'mm/base-state-mode)
+                                               nil)))
+                 nil
+                 nil)
+
+(mm/define-state mm/delete-state-mode
+                 " <D>"
+                 "red"
+                 `(,@mm/moves
+                   ,@mm/digits
+                   ,@(mapcar (lambda (key) (cons key 'keyboard-quit))
+                             mm/no-ops)
+                   ("m" . mm/do-nothing)
+                   ("d" . ,(mm/compose-command ((pop-mark)
+                                                (move-beginning-of-line nil)
+                                                (push-mark)
+                                                (next-line)
+                                                (move-beginning-of-line nil))
+                                               'mm/do-nothing
+                                               nil))
+                   )
+                 ;; enable
+                 ((let* ((transition (mm/transition-state 'mm/normal-state-mode))
+                         (disable-handler
+                          (mm/post-effect-enabler
+                           ;; hack to check if it was a prefix command
+                           (internal-echo-keystrokes-prefix)
+                           ((unless (internal-echo-keystrokes-prefix)
+                              (funcall transition)))
+                           t)))
+                    (push-mark)
+                    (setq-local mm/disable-delete nil)
+                    ;; TODO do these trigger before or after post command
+                    (add-hook 'window-selection-change-functions
+                              (lambda (window)
+                                (setq-local mm/disable-delete t))
+                              0 t)
+                    (add-hook 'window-buffer-change-functions
+                              (lambda (window)
+                                (setq-local mm/disable-delete t))
+                              0 t)
+                    (funcall disable-handler)))
+                 ((progn ;; disable
+                    ;; do deletion on mode exit
+                    (unless (or mm/disable-delete
+                                (eq this-command 'keyboard-quit))
+                      (kill-region nil nil t))
+                    )))
+
+;; should be a copy of delete mode, but switches to base after
+(mm/define-state mm/change-state-mode
+                 " <C>"
+                 "red"
+                 `(,@mm/moves
+                   ,@mm/digits
+                   ,@(mapcar (lambda (key) (cons key 'keyboard-quit))
+                             mm/no-ops)
+                   ("m" . mm/do-nothing)
+                   ("c" . ,(mm/compose-command ((pop-mark)
+                                                (move-beginning-of-line nil)
+                                                (push-mark)
+                                                (move-end-of-line nil))
+                                               'mm/do-nothing
+                                               nil)))
+                 ;; enable
+                 ((let* ((transition-n (mm/transition-state 'mm/normal-state-mode))
+                         (transition-b (mm/transition-state 'mm/base-state-mode))
+                         (disable-handler
+                          (mm/post-effect-enabler
+                           ;; hack to check if it was a prefix command
+                           (internal-echo-keystrokes-prefix)
+                           ((unless (internal-echo-keystrokes-prefix)
+                              (if (eq this-command 'keyboard-quit)
+                                  (funcall transition-n)
+                                (funcall transition-b))))
+                           t)))
+                    (push-mark)
+                    (setq-local mm/disable-delete nil)
+                    ;; TODO do these trigger before or after post command
+                    (add-hook 'window-selection-change-functions
+                              (lambda (window)
+                                (setq-local mm/disable-delete t))
+                              0 t)
+                    (add-hook 'window-buffer-change-functions
+                              (lambda (window)
+                                (setq-local mm/disable-delete t))
+                              0 t)
+                    (funcall disable-handler)))
+                 ((progn ;; disable
+                    ;; do deletion on mode exit
+                    (unless (or mm/disable-delete
+                                (eq this-command 'keyboard-quit))
+                      (kill-region nil nil t))
+                    )))
+
+(mm/define-state mm/yank-state-mode
+                 " <Y>"
+                 "purple"
+                 `(,@mm/moves
+                   ,@mm/digits
+                   ,@(mapcar (lambda (key) (cons key 'keyboard-quit))
+                             mm/no-ops)
+                   ("m" . ,(mm/compose-command ((pop-mark))
+                                               'mm/do-nothing
+                                               nil))
+                   ("y" . ,(mm/compose-command ((pop-mark)
+                                                (move-beginning-of-line nil)
+                                                (push-mark)
+                                                (move-end-of-line nil))
+                                               'mm/do-nothing
+                                               nil))
+                   )
+                 ;; enable
+                 ((let* ((transition (mm/transition-state 'mm/normal-state-mode))
+                         (disable-handler
+                          (mm/post-effect-enabler
+                           ;; hack to check if it was a prefix command
+                           (internal-echo-keystrokes-prefix)
+                           ((unless (internal-echo-keystrokes-prefix)
+                              (funcall transition)))
+                           t)))
+                    (push-mark)
+                    (setq-local mm/disable-delete nil)
+                    (funcall disable-handler)))
+                 ((progn ;; disable
+                    (unless (or mm/disable-delete
+                                (eq this-command 'keyboard-quit))
+                      (copy-region-as-kill nil nil t))
+                    )))
+
+(setq minions-prominent-modes (append mm/all-states minions-prominent-modes))
+
+(defun mm/enable-normal-state ()
   (interactive)
-  (if (yank-looks-like-lines)
-      (progn
-        (move-beginning-of-line nil)
-        (yank))
-    (yank)))
-
-(defun forward-char-unless-eol (&optional arg)
-  (interactive "P")
-  (when (< (point) (point-at-eol)) (forward-char arg)))
-
-(defun mark-end-of-line (&optional arg)
-  (interactive "P")
-  (push-mark)
-  (move-end-of-line arg)
-  (exchange-point-and-mark))
-
-(defun mark-beginning-of-line (&optional arg)
-  (interactive "P")
-  (push-mark)
-  (move-beginning-of-line arg)
-  (exchange-point-and-mark))
-
-;; what I really want is a meta operator to invert the arg count,
-;; but between how ryo calls functions and expects symbols in binds,
-;; this is the best I can do.
-(defun mark-word-backward (&optional arg allow-extend)
-  (interactive "P\np")
-  (cond
-   ((null arg)
-    (setq arg -1))
-   ((numberp arg)
-    (setq arg (* -1 arg))))
-  (mark-word arg allow-extend))
-
-(defun mark-sexp-backward (&optional arg allow-extend)
-  (interactive "P\np")
-  (cond
-   ((null arg)
-    (setq arg -1))
-   ((numberp arg)
-    (setq arg (* -1 arg))))
-  (mark-sexp arg allow-extend))
-
-(defun mark-defun-backward (&optional arg interactive)
-  (interactive "p\nd")
-  (cond
-   ((null arg)
-    (setq arg -1))
-   ((numberp arg)
-    (setq arg (* -1 arg))))
-  (mark-defun arg interactive))
-
-(defun mark-paragraph-backward (&optional arg allow-extend)
-  (interactive "P\np")
-  (cond
-   ((null arg)
-    (setq arg -1))
-   ((numberp arg)
-    (setq arg (* -1 arg))))
-  (mark-paragraph arg allow-extend))
-
-(defconst my/ryo-digits '(("1" "C-1" :norepeat t)
-                          ("2" "C-2" :norepeat t)
-                          ("3" "C-3" :norepeat t)
-                          ("4" "C-4" :norepeat t)
-                          ("5" "C-5" :norepeat t)
-                          ("6" "C-6" :norepeat t)
-                          ("7" "C-7" :norepeat t)
-                          ("8" "C-8" :norepeat t)
-                          ("9" "C-9" :norepeat t)))
-
-(defconst my/ryo-moves '(("h" backward-char)
-                         ("j" next-line)
-                         ("k" previous-line)
-                         ("l" forward-char)
-
-                         ("e" forward-word)
-                         ("b" backward-word)
-                         ("E" forward-sexp)
-                         ("B" backward-sexp)
-
-                         ("0" "C-a")
-                         ("$" "C-e")
-
-                         ("[" beginning-of-defun)
-                         ("]" end-of-defun)
-                         ("{" backward-paragraph)
-                         ("}" forward-paragraph)
-                         ))
-
-(defconst my/ryo-marking-moves '(("h" backward-char :first (push-mark-command))
-                                 ("j" next-line :first (push-mark-command))
-                                 ("k" previous-line :first (push-mark-command))
-                                 ("l" forward-char :first (push-mark-command))
-
-                                 ("b" mark-word-backward)
-                                 ("e" mark-word)
-                                 ("B" mark-sexp-backward)
-                                 ("E" mark-sexp)
-
-                                 ("[" mark-defun-backward)
-                                 ("]" mark-defun)
-
-                                 ("0" mark-beginning-of-line)
-                                 ("$" mark-end-of-line)
-
-                                 ("{" mark-paragraph-backward)
-                                 ("}" mark-paragraph)
-                                 ))
-
-(defconst my/ryo-no-ops '(
-                          "<escape>"
-                          "`" "-" "+"
-                          "q" "w" "r" "t" "\\"
-                          "s" "f" ";" "'"
-                          "z" "n" "m" "," "."
-
-                          "~" "!" "@" "#" "%" "^" "&" "*" "(" ")" "_" "+"
-                          "Q" "W" "R" "T" "Y" "U" "|"
-                          "S" "D" "F" "H" "J" "K" "L" ":" "\""
-                          "Z" "X" "C" "V" "N" "M" "<" ">"
-                          ))
-
-
-
-(use-package ryo-modal
-  :demand t
-  :bind (:map my/keys-mode-map
-              ("C-c C-<space>" . ryo-modal-mode))
-  :config
-  (define-minor-mode my/temp-nonmodal-mode
-    "Minor mode for a temporary exit that should return to ryo-modal-mode."
-    :keymap (define-keymap
-              "<escape>"
-              'my/temp-nonmodal-mode)
-    :lighter " <NM>"
-    (ryo-modal-mode (if my/temp-nonmodal-mode -1 1)))
-
-  (let* ()
-    (eval
-     `(ryo-modal-keys
-       ,@my/ryo-moves
-       ,@my/ryo-digits
-       ,@(mapcar (lambda (key) (list key 'do-nothing)) my/ryo-no-ops)
-       ("g" (("g" beginning-of-buffer)))
-       ("G" end-of-buffer)
-
-       ("i" my/temp-nonmodal-mode)
-       ("I" back-to-indentation :then '(my/temp-nonmodal-mode))
-       ("a" forward-char-unless-eol :then '(my/temp-nonmodal-mode))
-       ("A" move-end-of-line :then '(my/temp-nonmodal-mode))
-       ("o" move-end-of-line :then '(newline-and-indent my/temp-nonmodal-mode))
-       ("O" move-beginning-of-line
-        :then '(open-line indent-according-to-mode my/temp-nonmodal-mode))
-
-       ("x" delete-char)
-       ("d" (("d" kill-whole-line)
-             ("m" kill-region)))
-       ("d" ,my/ryo-marking-moves :then '(kill-region))
-
-       ("c" (("c" kill-whole-line))
-        :then '(open-line my/temp-nonmodal-mode))
-       ("c" (("m" kill-region))
-        :then '(my/temp-nonmodal-mode))
-       ("C" kill-line :then '(my/temp-nonmodal-mode))
-       ("c" ,my/ryo-marking-moves :then '(kill-region my/temp-nonmodal-mode))
-
-       ("y" (("m" copy-region-as-kill)))
-       ("y" (("y" copy-region-as-kill))
-        :first '(push-mark move-beginning-of-line push-mark move-end-of-line forward-char)
-        :then '(pop-mark pop-to-mark-command))
-
-       ("P" paste-before-maybe-lines)
-       ("p" paste-after-maybe-lines)
-
-       ("/" isearch-forward-regexp)
-       ("?" isearch-backward-regexp)
-
-       ("u" undo)
-
-       ("SPC" set-mark-command)
-       ("v" set-mark-command)
-       )))
-  (setq ryo-modal-cursor-color "aquamarine")
-  (defun ryo-modal-unless-minibuffer ()
-    (unless (minibufferp)
-      (ryo-modal-mode 1)))
-  ;; (add-hook 'after-change-major-mode-hook 'ryo-modal-unless-minibuffer)
-  )
+  (unless (minibufferp)
+    (mm/normal-state-mode 1)))
+
+(define-minor-mode mm/global-modal-mode
+  "Makes buffers start in normal state."
+  :global t
+  :interactive t
+  (if mm/global-modal-mode
+      (progn (add-hook 'after-change-major-mode-hook 'mm/enable-normal-state)
+             (mm/enable-normal-state))
+    (remove-hook 'after-change-major-mode-hook 'mm/enable-normal-state)))
+
+;; And we're off!
+(mm/global-modal-mode 1)