| git.druid.rocks | index | druid520 | radium | radium-macros.el |
radium-macros.el
;;; radium-macros.el, inline "![name]" / "![name:args]" text macros -*- lexical-binding: t; -*-
;;
;; type e.g. "![date]" and the instant i type the closing "]" it's
;; replaced with today's date; "![proto:vminit]" auto-fills a call to
;; vminit with its real parameters (radium-proto.el). anything that can
;; run a shell command lives in `radium-macro-confirm-alist' instead,
;; never auto-triggers, and always asks first - only reachable via `C-c e'.
;;
;; auto-trigger is suppressed in kona-mode: k itself uses a bare
;; operator immediately followed by "[", e.g. "![1;2;3]", which would
;; otherwise collide. `C-c e' still works there.
;;
;; a macro fn gets one string arg: "" for "![name]", or the text after
;; "name:" for "![name:...]". i use it for format strings (date:%Y),
;; counted repetition (spaces:12), lookups (env:USER), etc.
(defun radium-uuid4 ()
"a good-enough (not cryptographically secure) uuidv4 for editor use."
(format "%04x%04x-%04x-%04x-%04x-%04x%04x%04x"
(random 65536) (random 65536)
(random 65536)
(logior #x4000 (logand (random 65536) #x0fff))
(logior #x8000 (logand (random 65536) #x3fff))
(random 65536) (random 65536) (random 65536)))
(defun radium-macro--count (str)
"STR spaces if STR is a positive integer, else 4 spaces."
(let ((n (string-to-number str)))
(if (and (> n 0) (string-match-p "\\`[0-9]+\\'" str))
(make-string n ?\s)
(make-string 4 ?\s))))
(defvar radium-macro-safe-alist
(list
(cons "date" (lambda (a) (format-time-string (if (string-empty-p a) "%Y-%m-%d" a))))
(cons "time" (lambda (a) (format-time-string (if (string-empty-p a) "%H:%M:%S" a))))
(cons "datetime" (lambda (a) (format-time-string (if (string-empty-p a) "%Y-%m-%d %H:%M:%S" a))))
(cons "user" (lambda (_a) user-login-name))
(cons "host" (lambda (_a) (or (getenv "HOSTNAME") (system-name))))
(cons "file" (lambda (_a) (if buffer-file-name (file-name-nondirectory buffer-file-name) "")))
(cons "dir" (lambda (_a) (if buffer-file-name (file-name-directory buffer-file-name) "")))
(cons "basename" (lambda (_a) (if buffer-file-name (file-name-sans-extension (file-name-nondirectory buffer-file-name)) "")))
(cons "path" (lambda (_a) (or buffer-file-name "")))
(cons "line" (lambda (_a) (number-to-string (line-number-at-pos))))
(cons "lang" (lambda (_a) (symbol-name major-mode)))
(cons "guard" (lambda (_a) (radium-header-guard-name)))
(cons "spaces" (lambda (a) (radium-macro--count a)))
(cons "wid" (lambda (_a) (format "%s:%d" (or (getenv "HOSTNAME") (system-name)) (emacs-pid))))
(cons "env" (lambda (a) (or (getenv a) "")))
(cons "uuid" (lambda (_a) (radium-uuid4)))
(cons "epoch" (lambda (_a) (format-time-string "%s")))
(cons "rand" (lambda (a) (number-to-string (random (max 1 (string-to-number (if (string-empty-p a) "1000000" a)))))))
(cons "branch" (lambda (_a) (or (radium-git-current-branch) "")))
(cons "proto" (lambda (a) (radium-insert-call-for-name a) :handled))
(cons "help" (lambda (_a) (radium-macro-show-help) :handled)))
"macro name -> function of the ARGS string -> replacement text (or
:handled if the fn did its own insertion). auto-expanded as soon as the
closing bracket is typed.")
(defvar radium-macro-confirm-alist
(list
(cons "shell" (lambda (a)
(if (yes-or-no-p (format "run shell command and insert its output? `%s' " a))
(string-trim (shell-command-to-string a))
"")))
(cons "gitlog" (lambda (_a)
(if (yes-or-no-p "insert last 5 git log lines? ")
(shell-command-to-string "git log --oneline -5")
""))))
"macros only reachable via `C-c e' (`radium-macro-expand-at-point'),
never by the auto-typing-trigger, because they can execute things.")
(defvar radium-macro-help-alist
(list
(cons "date" "today's date, or ![date:FMT] with any strftime format")
(cons "time" "the current time, or ![time:FMT]")
(cons "datetime" "date + time together, or ![datetime:FMT]")
(cons "user" "user-login-name")
(cons "host" "the hostname")
(cons "file" "this buffer's own filename, no directory")
(cons "dir" "this buffer's own directory")
(cons "basename" "this buffer's filename, no directory and no extension")
(cons "path" "this buffer's own full path")
(cons "line" "the current line number")
(cons "lang" "this buffer's major-mode, as a symbol")
(cons "guard" "FOO_BAR_H for a file named foo-bar.h")
(cons "spaces" "![spaces:N] - N literal spaces, 4 if N is missing/not a number")
(cons "wid" "hostname:pid, a work-id for a running process")
(cons "env" "![env:VAR] - the environment variable VAR, or empty")
(cons "uuid" "a fresh uuidv4 (not cryptographically secure)")
(cons "epoch" "the current unix timestamp")
(cons "rand" "![rand:N] - a random integer in [0,N), 1000000 if N is missing")
(cons "branch" "the current git branch, or empty outside a repo")
(cons "proto" "![proto:name] - a call to name with real param names, from gtags")
(cons "help" "this listing")
(cons "shell" "(C-c e only, always asks) ![shell:cmd] - cmd's own stdout")
(cons "gitlog" "(C-c e only, always asks) the last 5 `git log --oneline' lines"))
"macro name -> one-line description, for `radium-macro-show-help'
only - never consulted by expansion itself, so a name missing here
just gets no help text rather than failing to expand.")
(defun radium-macro-show-help ()
"C-c h, or ![help]: a *radium-macros-help* buffer listing every
real macro name (both tables - the confirm-only ones marked as such)
with its one-line description."
(interactive)
(with-current-buffer (get-buffer-create "*radium-macros-help*")
(let ((inhibit-read-only t))
(erase-buffer)
(insert "![name] or ![name:args] macros - auto-expand on typing "
"the closing ], or C-c e to expand the one before point by hand.\n\n")
(dolist (name (sort (mapcar #'car radium-macro-safe-alist) #'string<))
(insert (format " %-10s %s\n" name (or (cdr (assoc name radium-macro-help-alist)) ""))))
(dolist (name (sort (mapcar #'car radium-macro-confirm-alist) #'string<))
(unless (assoc name radium-macro-safe-alist)
(insert (format " %-10s %s\n" name (or (cdr (assoc name radium-macro-help-alist)) "")))))
(goto-char (point-min))
(view-mode 1))
(display-buffer (current-buffer))))
(defun radium-macro--parse (text)
(if (string-match "\\`\\([^:]+\\):\\(.*\\)\\'" text)
(cons (match-string 1 text) (match-string 2 text))
(cons text "")))
(defun radium-macro--try-expand-before-point (table)
(let ((end (point))
(limit (max (point-min) (- (point) 400))))
;; the automatic trigger only ever calls this with point right
;; after a `]' just typed, so `end' being one-past-a-real-`]' was
;; never checked, just assumed - C-c e (radium-macro-expand-at-
;; point) calls this same function with point wherever it happens
;; to be, though, and without this guard a point one short of the
;; `]' silently truncates `inside' (dropping its last real
;; character) and never sees a bracket to trip the "no brackets
;; inside" check, so it expands a corrupted name and deletes only
;; up to `end' - leaving the real `]' behind in the buffer.
;; confirmed by reproducing exactly that before this guard existed.
(when (eq (char-before end) ?\])
(save-excursion
(goto-char end)
(when (search-backward "![" limit t)
(let* ((start (point))
(inside (buffer-substring-no-properties (+ start 2) (1- end))))
(unless (string-match-p "[][]" inside)
(let* ((parsed (radium-macro--parse inside))
(fn (cdr (assoc (car parsed) table))))
(when fn
(goto-char start)
(delete-region start end)
(let ((result (funcall fn (cdr parsed))))
(unless (eq result :handled)
(insert result)))
t)))))))))
(defun radium-macro-trigger ()
(when (and (eq last-command-event ?\])
(not (minibufferp))
(not (derived-mode-p 'kona-mode))
;; a comment/string is prose, not code - dont let e.g. a
;; stray "![date]"-looking aside in a code comment get
;; silently mangled. same guard radium-lang-c.el's
;; varinit-trigger already uses.
(not (nth 8 (syntax-ppss))))
(radium-macro--try-expand-before-point radium-macro-safe-alist)))
(defun radium-macro-expand-at-point ()
"expand the `![...]' macro right before point, trying the safe table
first and then the confirm-required one."
(interactive)
(or (radium-macro--try-expand-before-point radium-macro-safe-alist)
(radium-macro--try-expand-before-point radium-macro-confirm-alist)
(message "err: no ![...] macro before point.")))
(add-hook 'post-self-insert-hook #'radium-macro-trigger)
(global-set-key (kbd "C-c e") #'radium-macro-expand-at-point)
(global-set-key (kbd "C-c h") #'radium-macro-show-help)
;; C-c p: process the whole buffer through a real script
;;
;; items 9/23 (filed as duplicates - one and the same feature): "like
;; babel" but for any file, not just an org #+begin_src block - write
;; a real, possibly multi-line script in perl/elisp/scheme/commonlisp,
;; run it against the buffer's own text, replace the buffer with the
;; result. the script gets its own edit buffer, real major-mode
;; highlighting/indentation included, same edit-special shape
;; org-babel's own C-c ' already uses and for the same reason: a real
;; processing script deserves that, not a one-line minibuffer prompt.
;;
;; each language's actual input/output convention was verified
;; directly against a real perl/sbcl/chez, not assumed: perl gets
;; `-0777 -pe SCRIPT' (slurp mode - the whole buffer lands in $_,
;; SCRIPT mutates it, -p auto-prints the result, the real perl one-
;; liner idiom, not a from-scratch read/write wrapper); elisp needs no
;; subprocess at all, SCRIPT just has to be real elisp whose last form
;; evaluates to the new text, with radium-proc-text (a real defvar,
;; genuinely special/dynamic even under this file's own lexical-
;; binding, checked directly - a plain (let ((text ...)) (eval
;; (read-from-string script))) would NOT be visible to forms read
;; from a string this way) bound to the old text as SCRIPT runs;
;; scheme/commonlisp are real external processes with no shared
;; memory to bind a variable into at all, so they get the old text on
;; stdin and are expected to write the new text to stdout - the
;; wrapper each one runs handles the actual read-all-of-stdin/print-
;; the-final-value plumbing so SCRIPT itself only needs to reference
;; `text' (scheme) or `text' (commonlisp) as a bound variable and
;; leave its own last form's value to become the output, the same
;; shape as the elisp case.
(defvar radium-proc-lang-modes
'((perl . cperl-mode) (elisp . emacs-lisp-mode)
(scheme . scheme-mode) (commonlisp . lisp-mode))
"language symbol -> major mode for C-c p's own script-editing buffer.")
(defvar radium-proc-text nil
"the buffer-being-processed's old text, bound while an elisp C-c p
script runs - genuinely special (defvar'd) on purpose: a script read
fresh from a string via `read' has no access to an ordinary lexical
`let', only to a real dynamic/special variable.")
(defvar-local radium-proc--target nil
"in a C-c p script-editing buffer: the buffer C-c C-c processes.")
(defvar-local radium-proc--lang nil
"in a C-c p script-editing buffer: which language it's in.")
(defun radium-proc--run-perl (text script)
(with-temp-buffer
(insert text)
(unless (zerop (call-process-region (point-min) (point-max) "perl" t t nil "-0777" "-pe" script))
(error "radium-proc: perl failed: %s" (buffer-string)))
(buffer-string)))
(defun radium-proc--run-elisp (text script)
(let ((radium-proc-text text))
(format "%s" (eval (read (format "(progn %s)" script)) t))))
(defun radium-proc--run-external (interp extra-args wrapper text script)
"run INTERP EXTRA-ARGS... SCRIPTFILE (SCRIPTFILE holding WRAPPER, a
format string with one %s for SCRIPT), feeding TEXT on stdin,
returning stdout - the shared shape scheme/commonlisp both need, only
the wrapper text (and whether the interpreter needs an explicit
--script-style flag before the file at all) differs. checked directly
against a real chez/sbcl, not assumed - and a real mistake this
caught before it shipped: a bare `chez FILE' or `sbcl FILE' does NOT
run FILE and exit the way `--script FILE' does for either of them
(sbcl's own bare-file form drops into an interactive-looking repl
without ever actually running the file's own top-level forms at all -
confirmed directly, not just suspected). both need the real flag."
(let ((scriptfile (make-temp-file "radium-proc")))
(unwind-protect
(progn
(with-temp-file scriptfile (insert (format wrapper script)))
(with-temp-buffer
(insert text)
(unless (zerop (apply #'call-process-region (point-min) (point-max) interp t t nil
(append extra-args (list scriptfile))))
(error "radium-proc: %s failed: %s" interp (buffer-string)))
(buffer-string)))
(delete-file scriptfile))))
(defun radium-proc--run-scheme (text script)
(radium-proc--run-external
"chez" '("--script")
"(let ([text (get-string-all (current-input-port))]) (display (begin %s)))"
text script))
(defun radium-proc--run-commonlisp (text script)
(radium-proc--run-external
"sbcl" '("--script")
"(let ((text (with-output-to-string (out) (loop for line = (read-line *standard-input* nil) while line do (write-line line out))))) (write-string (progn %s)))"
text script))
(defun radium-proc-run ()
"run this C-c p script buffer (C-c C-c) against the buffer it was
opened for, replacing that buffer's whole content with the result."
(interactive)
(let* ((script (buffer-string))
(target radium-proc--target)
(lang radium-proc--lang)
(text (with-current-buffer target (buffer-string)))
(scriptbuf (current-buffer))
(result
(pcase lang
('perl (radium-proc--run-perl text script))
('elisp (radium-proc--run-elisp text script))
('scheme (radium-proc--run-scheme text script))
('commonlisp (radium-proc--run-commonlisp text script)))))
(with-current-buffer target
(erase-buffer)
(insert result))
(kill-buffer scriptbuf)
(message "radium-proc: %s done, %s updated." lang (buffer-name target))))
(defun radium-macro-process-buffer (lang)
"C-c p: process the whole current buffer through a script written
in LANG (perl/elisp/scheme/commonlisp), replacing its content with
the result - opens a script-editing buffer (C-c C-c runs it, C-c C-k
cancels)."
(interactive (list (intern (completing-read "process buffer with: "
'("perl" "elisp" "scheme" "commonlisp") nil t))))
(let* ((target (current-buffer))
(buf (generate-new-buffer (format "*radium-proc:%s*" lang))))
(with-current-buffer buf
(funcall (alist-get lang radium-proc-lang-modes))
(setq radium-proc--target target
radium-proc--lang lang)
(local-set-key (kbd "C-c C-c") #'radium-proc-run)
(local-set-key (kbd "C-c C-k") (lambda () (interactive) (kill-buffer))))
(pop-to-buffer buf)
(message "write the %s script, C-c C-c to run it against %s, C-c C-k to cancel"
lang (buffer-name target))))
(global-set-key (kbd "C-c p") #'radium-macro-process-buffer)
(provide 'radium-macros)