path: root/config/emacs/site-lisp/my-modal.el

;;; 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)

                     (,(kbd "<return>") . next-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" "F" "H" "J" "K" "L" ":" "\""
                      "Z" "X" "V" "N" "M" "<" ">"
                      ))

(defvar-local mm/state 'nil)
(defvar mm/all-states '())
;; pairs of (state-mode-symbol . cursor color)
(defvar mm/state-color-alist (list (cons nil (face-background 'cursor))))

(defmacro mm/transition-state (to)
  `(lambda ()
     (interactive)
     (funcall mm/state -1)
     (funcall ,to 1)))

(defmacro mm/define-state (name lighter color keymap enable disable)
  `(let ((lighter ,lighter))
     (add-face-text-property 0 (length lighter) '(:foreground ,color) t lighter)
     (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)
     (add-to-list 'mm/state-color-alist (cons ',name ,color))))

;; 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)
                   ("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))
                   ("D" . kill-line)
                   ("c" . ,(mm/transition-state 'mm/change-state-mode))
                   ("C" . ,(mm/compose-command ((kill-line nil))
                                               (mm/transition-state 'mm/base-state-mode)
                                               nil))

                   ("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))
                   ("x" . delete-char)

                   ("/" . isearch-forward-regexp)
                   ("?" . isearch-backward-regexp))
                 nil
                 nil)

(mm/define-state mm/special-state-mode
                 " <S>"
                 "light sea green"
                 `(,@mm/moves
                   ,@mm/digits
                   (,(kbd "SPC") . set-mark-command)
                   ;; TODO introude mm/last-state and add yank here
                   )
                 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/compose-command
                            ((pop-mark))
                            'mm/do-nothing
                            nil))
                   ("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/compose-command
                            ((pop-mark))
                            'mm/do-nothing
                            nil))
                   ("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)
                                                (forward-char 1))
                                               '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))
                      (progn
                        (copy-region-as-kill nil nil t)
                        (pop-to-mark-command))))))

(mapc (lambda (mode) (add-to-list 'minions-prominent-modes mode)) mm/all-states)

(defun mm/ensure-color (frame)
  (interactive)
  (let ((color (alist-get mm/state mm/state-color-alist)))
    (when color
      (set-face-background 'cursor color))))

(defvar mm/starting-mode-alist '((eshell-mode . mm/base-state-mode)
                                 (term-mode . mm/base-state-mode)
                                 (vterm-mode . mm/base-state-mode)
                                 (eat-mode . mm/base-state-mode)
                                 (vc-git-log-edit-mode . mm/base-state-mode))
  "Alist of (major-mode . starting-state-mode).")

(defun mm/pick-starting-state (&optional buffer)
  (unless buffer (setq buffer (current-buffer)))
  (with-current-buffer buffer
    (cond
     ((alist-get major-mode mm/starting-mode-alist))
     (buffer-read-only 'mm/special-state-mode)
     (t 'mm/normal-state-mode))))

(defun mm/enable-starting-state (&optional buffer)
  (unless (minibufferp)
    (unless buffer (setq buffer (current-buffer)))
    (with-current-buffer buffer
      (funcall (mm/pick-starting-state buffer) 1))))

(defun mm/enable-starting-state-unless-set  (&optional buffer)
  (unless buffer (setq buffer (current-buffer)))
  (unless (or (minibufferp) (string-match-p "^ " (buffer-name buffer)))
    (with-current-buffer buffer
      (unless mm/state
        (funcall (mm/pick-starting-state buffer) 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-starting-state-unless-set)
        (add-hook 'window-selection-change-functions 'mm/ensure-color)
        (add-hook 'window-buffer-change-functions 'mm/ensure-color)
        (if mm/state
            (mm/transition-state (mm/pick-starting-state))
          (mm/enable-starting-state)))
    (progn
      (remove-hook 'after-change-major-mode-hook 'mm/enable-starting-state-unless-set)
      (remove-hook 'window-selection-change-functions 'mm/ensure-color)
      (remove-hook 'window-buffer-change-functions 'mm/ensure-color)
      (setq this-command 'keyboard-quit)
      (mm/transition-state 'mm/normal-state-mode)
      (mm/normal-state-mode -1)
      (setq mm/state nil)
      (set-face-background 'cursor (alist-get nil mm/state-color-alist)))))

;; And we're off!
(mm/global-modal-mode 1)