From 1f668e67753ac1c355677611d7057f5ca0982219 Mon Sep 17 00:00:00 2001 From: Thomas Ulmer Date: Tue, 10 Feb 2026 16:12:54 -0800 Subject: basic version of bespoke modal --- config/emacs/site-lisp/my-modal.el | 522 ++++++++++++++++++++++--------------- 1 file 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 "") + "`" "-" "+" + "q" "w" "r" "t" "\\" + "s" "f" ";" "'" + "z" "n" "," "." + + "~" "!" "@" "#" "%" "^" "&" "*" "(" ")" "_" "+" + "Q" "W" "R" "T" "Y" "U" "|" + "S" "D" "F" "H" "J" "K" "L" ":" "\"" ,(kbd "") + "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 + " " + "turquoise" + `((,(kbd "") . ,(mm/transition-state 'mm/normal-state-mode))) + nil + nil) + +(mm/define-state mm/normal-state-mode + " " + "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 + " " + "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 + " " + "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 + " " + "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 '( - "" - "`" "-" "+" - "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-" . 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 - "" - 'my/temp-nonmodal-mode) - :lighter " " - (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) -- cgit v1.2.3