commit 6e9dd97d8f94747431925dbd965e2c082fa340d4 parent cd66fdb387f977710a346be47aa61e672b9442f2 Author: Vincent Demeester <vincent@sbr.pm> Date: Tue, 20 Aug 2024 21:57:19 +0200 tools/emacs: import and try portals See https://chrisdone.com/posts/portals/. I really like the concept. Signed-off-by: Vincent Demeester <vincent@sbr.pm> Diffstat:
| A | tools/emacs/lisp/portal.el | | | 546 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 546 insertions(+), 0 deletions(-)
diff --git a/tools/emacs/lisp/portal.el b/tools/emacs/lisp/portal.el @@ -0,0 +1,546 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customizations + +(defgroup portal nil + "Portal group." + :group 'convenience) + +(defcustom portal-outputs-directory + "~/.portals/" + "Directory where to create output artifacts." + :type 'string :group 'portal) + +(defcustom portal-default-stdout-buffer-len + 4096 + "Default buffer length for the stdout preview." + :group 'portal :type 'number) + +(defcustom portal-default-stderr-buffer-len + 4096 + "Default buffer length for the stderr preview." + :group 'portal :type 'number) + +(defface portal-face + '((((class color) (background dark)) + (:foreground "#fff" :bold t)) + (((class color) (background light)) + (:foreground "#000" :bold t))) + "Portal face." + :group 'portal) + +(defface portal-exited-stdout-face + '((t :foreground "#acac9e")) + "Portal exited stdout face." + :group 'portal) + +(defface portal-exited-stderr-face + '((t :foreground "#aa7070")) + "Portal exited stderr face." + :group 'portal) + +(defface portal-exit-success-face + '((t :foreground "#89b664")) + "Portal exit successful face." + :group 'portal) + +(defface portal-exit-failure-face + '((t :foreground "#ae6161")) + "Portal exit failure face." + :group 'portal) + +(defface portal-meta-face + '((t :foreground "#89b664")) + "Portal meta face." + :group 'portal) + +(defface portal-stdout-face + '((t :inherit 'default)) + "Portal stdout face." + :group 'portal) + +(defface portal-stderr-face + '((t :foreground "#ae6161")) + "Portal stderr face." + :group 'portal) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Interactive commands + +(defun portal-insert-shell-command (command) + "Launch an asynchronous shell of COMMAND, make a portal associated +with the current buffer and insert the portal into the current +buffer." + (interactive "sCommand: ") + (portal-insert-command + (list shell-file-name shell-command-switch command))) + +(defun portal-open-stdout () + "Open the stdout of the file at point." + (interactive) + (find-file (portal-file-name (portal-at-point) "stdout"))) + +(defun portal-open-stderr () + "Open the stderr of the file at point." + (interactive) + (find-file (portal-file-name (portal-at-point) "stderr"))) + +(defun portal-interrupt () + "Interrupt the process at point." + (interactive) + (let ((proc (get-process (portal-process-name (portal-at-point))))) + (when (process-live-p proc) + (interrupt-process proc)))) + +(defun portal-rerun () + "Re-run portal at point." + (interactive) + (portal-jump-to-portal) + (let* ((portal (portal-at-point)) + (command (portal-read-json-file portal "command")) + (env (portal-read-json-file portal "env")) + (default-directory (portal-read-json-file portal "directory"))) + (portal-interrupt) + (delete-region (line-beginning-position) (line-end-position)) + (portal-wipe-summary) + (portal-insert-command (append command nil)) + (portal-refresh-soon))) + +(defun portal-edit () + "Edit and re-run portal at point." + (interactive) + (portal-jump-to-portal) + (portal-interrupt) + (let* ((portal (portal-at-point)) + (command + (vector + shell-file-name + shell-command-switch + (read-from-minibuffer + "Command: " + (portal-as-shell-command (portal-read-json-file portal "command"))))) + (env (portal-read-json-file portal "env")) + (default-directory (portal-read-json-file portal "directory"))) + (delete-region (line-beginning-position) (line-end-position)) + (portal-wipe-summary) + (portal-insert-command (append command nil)) + (portal-refresh-soon))) + +(defun portal-clone () + "Clone the portal at point." + (interactive) + (portal-jump-to-portal) + (let* ((portal (portal-at-point)) + (command (portal-read-json-file portal "command")) + (env (portal-read-json-file portal "env")) + (default-directory (portal-read-json-file portal "directory"))) + (save-excursion (insert "\n")) + (portal-insert-command (append command nil)) + (portal-refresh-soon))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Launching processes + +(defun portal-start (buffer portal stdout-path stderr-path program program-args) + "Run PROGRAM-PATH with ARGS, connect it to portal PORTAL in buffer +BUFFER, and write the stdout to STDOUT-PATH and stderr to +STDERR-PATH." + (let* ((stderr-pipe + (make-pipe-process + :name (portal-stderr-process-name portal) + :buffer buffer + :noquery t + :filter 'portal-process-filter + :sentinel 'portal-stderr-pipe-sentinel)) + (main-process + (make-process + :name (portal-process-name portal) + :buffer buffer + :command (cons program program-args) + :noquery nil + :connection-type 'pipe + :sentinel 'portal-main-process-sentinel + :filter 'portal-process-filter + :stderr stderr-pipe))) + + (process-put stderr-pipe :portal portal) + (process-put stderr-pipe :output-path stderr-path) + (process-put stderr-pipe :buffer "") + (process-put stderr-pipe :buffer-len portal-default-stderr-buffer-len) + + (process-put main-process :portal portal) + (process-put main-process :output-path stdout-path) + (process-put main-process :buffer "") + (process-put main-process :buffer-len portal-default-stdout-buffer-len) + + ;; Connect the two processes. + (process-put main-process :stderr-process stderr-pipe) + + (portal-write-json-file portal "command" (apply #'vector (cons program program-args))) + (portal-write-json-file portal "env" (apply #'vector process-environment)) + (portal-write-json-file portal "directory" default-directory) + (portal-write-json-file portal "status" (format "%S" (process-status main-process))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process filtering + +(defun portal-process-filter (process output) + (let ((filepath (process-get process :output-path))) + (when debug-on-error + (message "portal-process-filter: Writing to %s" filepath)) + (portal-accumulate-buffer process output) + (with-temp-buffer + (insert output) + (write-region (point-min) (point-max) filepath :append :no-messages)))) + +(defun portal-accumulate-buffer (process output) + "Accumulate some OUTPUT into PROCESS's preview buffer." + (process-put + process + :buffer (portal-shrink-preview + (process-get process :buffer-len) + (concat (process-get process :buffer) output)))) + +(defun portal-shrink-preview (len string) + "Shrink a preview buffer STRING to the right length." + (if (> (length string) len) + (substring string (- len)) + string)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Sentinels + +(defun portal-main-process-sentinel (process event) + "Handles the main process's status updates." + (when debug-on-error + (message "main-process-sentinel: %S: %S" process event)) + (portal-write-json-file + (process-get process :portal) + "status" (format "%S" (process-exit-status process)))) + +(defun portal-stderr-pipe-sentinel (process event) + "Handles the stderr pipe's status updates." + (when debug-on-error + (message "stderr-pipe-sentinel: %S: %S" process event))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; File/directory operations + +(defun portal-ensure-directory (portal) + "Create the stdout/stderr files for PORTAL in an appropriate +location." + (let ((directory (concat (file-name-as-directory portal-outputs-directory) portal))) + (make-directory directory :including-parents) + directory)) + +(defun portal-directory-exists-p (portal) + "Check PORTAL has a directory that exists." + (let ((directory (concat (file-name-as-directory portal-outputs-directory) portal))) + (file-exists-p directory))) + +(defun portal-file-exists-p (portal name) + "Check PORTAL has a file NAME that exists." + (let ((directory (concat (file-name-as-directory portal-outputs-directory) portal))) + (file-exists-p (concat (file-name-as-directory directory) name)))) + +(defun portal-persist-file (portal name content) + "Persist CONTENT to disk with filename NAME." + (with-temp-buffer + (insert content) + (write-region + (point-min) (point-max) + (portal-file-name portal name) + nil ; no-append + :no-messages)) + content) + +(defun portal-write-json-file (portal name expr) + "Print EXPR to disk with filename NAME." + (with-temp-buffer + (insert (json-serialize expr)) + (write-region + (point-min) (point-max) + (portal-file-name portal name) + nil ; no-append + :no-messages)) + expr) + +(defun portal-read-json-file (portal name) + "Read JSON content from file NAME for the given PORTAL." + (with-temp-buffer + (insert-file-contents (portal-file-name portal name)) + (json-parse-string (buffer-string)))) + +(defun portal-read-file (portal name) + "Read content from file NAME for the given PORTAL." + (with-temp-buffer + (let ((file (portal-file-name portal name))) + (when (file-exists-p file) + (insert-file-contents file))) + (buffer-string))) + +(defun portal-tail-file (portal n name) + "Tail last N lines of file NAME for the given PORTAL." + (with-temp-buffer + (let ((file (portal-file-name portal name))) + (if (file-exists-p file) + (portal-tail-n-lines n file) + "")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Nano-IDs + +(defun portal-generate-nanoid () + "Generate a Nano ID of the form `portal_NGMyMDVkZjZiYTVlZTVhM' using SHA-1." + (let* ((random-string (format "%s%s%S" (emacs-pid) (current-time-string) (random))) + (sha1-hash (secure-hash 'sha1 random-string)) + (base64-encoded (base64-encode-string sha1-hash)) + (nanoid (string-trim-right (substring base64-encoded 0 21)))) + (concat "portal_" nanoid))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; A small minor mode that just sets up a timer that runs a thing in a +;; given buffer every N seconds + +(defvar-local portal-alpha-timer + nil) + +(define-minor-mode portal-alpha-minor-mode + "TODO" + :init-value nil + :lighter "@" + (when portal-alpha-timer (cancel-timer portal-alpha-timer)) + (when portal-alpha-minor-mode + (setq portal-alpha-timer + (run-with-timer 1 2 'portal-beta-refresh (current-buffer))))) + +(defun portal-refresh-soon () + "Trigger a refresh within the blink of an eye, but no sooner, or +later." + (run-with-timer 0.100 nil 'portal-beta-refresh (current-buffer))) + +(defun portal-beta-refresh (buffer) + "Refresh portal displays." + (when (buffer-live-p buffer) + (let ((window (get-buffer-window buffer))) + (when window + (with-current-buffer buffer + (let ((point (point))) + (save-excursion + (goto-char (point-min)) + (while (and (re-search-forward portal-regexp nil t nil) + (<= (point) (window-end window))) + (when (<= (window-start window) (point) (window-end window)) + (let* ((portal (match-string 0)) + (process (get-process (portal-process-name portal))) + (summary (if (portal-directory-exists-p portal) + (portal-summary portal process) + "# Invalid portal.")) + (match-end (match-end 0)) + (old-summary (get-text-property (line-beginning-position) 'portal-summary))) + (unless (and old-summary (string= summary old-summary)) + (put-text-property (line-beginning-position) (point) + 'portal-summary + summary) + (put-text-property (line-beginning-position) (point) + 'portal + portal) + (portal-wipe-summary) + (insert "\n" summary)))))) + (goto-char point))))))) + +(defun portal-wipe-summary () + "Wipe the '# summary' lines that follow the portal." + (save-excursion + (when (looking-at "\n#") + (forward-line 1) + (let ((point (point))) + (or (search-forward-regexp "^[^#]" nil t 1) + (goto-char (point-max))) + (delete-matching-lines "^#" point (point)))))) + +(defun portal-summary (portal process) + "Generate a summary of the portal." + (let* ((command (portal-read-json-file portal "command")) + (directory (portal-read-json-file portal "directory")) + (status (portal-read-json-file portal "status")) + (stdout (if process + (portal-last-n-lines + 5 + (process-get process :buffer)) + (portal-tail-file portal 5 "stdout"))) + (stderr (if process + (portal-last-n-lines + 5 + (process-get (process-get process :stderr-process) :buffer)) + (portal-tail-file portal 5 "stderr")))) + (with-temp-buffer + (insert (propertize + (concat "# (" status ") " (portal-as-shell-command command)) + 'face + (if (string= status "run") + 'portal-meta-face + (if (string= status "0") + 'portal-exit-success-face + 'portal-exit-failure-face)))) + ;; Only show if it's different to the current directory, + ;; otherwise it's noise. + (unless (string= default-directory directory) (insert "\n# " directory)) + (unless (= 0 (length (string-trim stdout))) + (insert "\n" + (propertize (portal-clean-output stdout) + 'face (if (string= status "run") + 'portal-stdout-face + 'portal-exited-stdout-face)))) + (unless (= 0 (length (string-trim stderr))) + (insert "\n" + (propertize (portal-clean-output stderr) + 'face + (if (string= status "run") + 'portal-stderr-face + 'portal-exited-stderr-face)))) + (propertize (buffer-string) + 'portal portal)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; String generation + +(defun portal-as-shell-command (command) + "If the vector COMMAND is a shell run, strip the prefix, else return the whole thing joined." + (if (and (= 3 (length command)) + (string= (elt command 0) shell-file-name) + (string= (elt command 1) shell-command-switch)) + (elt command 2) + (mapconcat 'shell-quote-argument command " "))) + +(defun portal-clean-output (output) + "Clean output for previewing, prefixed with #." + (portal-limit-lines-to-80-columns + (concat "# " (replace-regexp-in-string + "\n" "\n# " + (portal-no-empty-lines output))))) + +(defun portal-limit-lines-to-80-columns (string) + "Limit all lines in STRING to 80 columns." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (not (eobp)) + (move-to-column 80 t) + (delete-region (point) (line-end-position)) + (forward-line)) + (buffer-string))) + +(defun portal-process-name (portal) + (concat portal "-main-process")) + +(defun portal-stderr-process-name (portal) + (concat portal "-stderr-pipe")) + +(defun portal-file-name (portal name) + (concat (file-name-as-directory (portal-ensure-directory portal)) name)) + +(defun portal-no-empty-lines (string) + "Drop empty lines from a string." + (replace-regexp-in-string "\n$" "" string)) + +(defun portal-last-n-lines (n string) + "Take last N lines from STRING." + (mapconcat #'identity (reverse (seq-take (reverse (split-string string "[\r\n]+" t)) n)) "\n")) + +(defun portal-tail-n-lines (n file-path) + "Tail the last N lines from FILE-PATH using tail, if possible. If +not possible (due to lack of such tool), return nil." + (let ((this-buffer (current-buffer))) + (with-temp-buffer + (let ((out-buffer (current-buffer))) + (with-current-buffer this-buffer + (cl-case (call-process "tail" nil out-buffer nil "-n" (format "%d" n) + (expand-file-name file-path)) + (0 (with-current-buffer out-buffer (buffer-string))) + (t ""))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Finding portals and gathering information for them + +(defconst portal-regexp "\\<portal_[A-Za-z0-9]\\{21\\}\\>" + "Match on a portal's unique ID.") + +(defun portal-at-point () + "Return the portal at point." + (or (save-excursion + (goto-char (line-beginning-position)) + (when (looking-at portal-regexp) + (buffer-substring (match-beginning 0) (match-end 0)))) + (get-text-property (point) 'portal) + (error "Not at a portal."))) + +(defun portal-jump-to-portal () + "If there's a portal at point or a summary of a portal at point, +jump to the portal at the beginning of the line upwards within +the same paragraph." + (let ((portal (portal-at-point))) + (goto-char + (save-excursion + (goto-char (line-end-position)) + (re-search-backward + (concat "^" (regexp-quote portal)) + (save-excursion (forward-paragraph -1)) + nil + 1))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Notes + +;; Use this on a portals buffer to stop it constantly being saved: +; +;; (setq buffer-save-without-query t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Major mode + +(defvar-keymap portal-mode-map + "M-!" 'portal-shell-command + "C-c C-c" 'portal-interrupt + "RET" 'portal-jump-to-thing-at-point + ) + +(define-derived-mode portal-mode + fundamental-mode "Portals" + "Major mode for portals." + (portal-alpha-minor-mode)) + +(defun portal-insert-command (command) + "Launch an asynchronous proc of COMMAND, make a portal associated +with the current buffer and insert the portal into the current +buffer." + (let* ((portal (portal-generate-nanoid))) + (portal-start + (current-buffer) + portal + (portal-file-name portal "stdout") + (portal-file-name portal "stderr") + (car command) + (cdr command)) + (insert portal))) + +(defun portal-shell-command (command) + "Run a shell command and insert it at point." + (interactive "sCommand: ") + (portal-insert-command + (list shell-file-name shell-command-switch command))) + +(defun portal-jump-to-thing-at-point () + "Jump to the thing at point, i.e. an stdout/stderr output jumps to +the file." + (interactive) + (let ((face (get-text-property (point) 'face))) + (cond + ((eq face 'portal-stderr-face) + (portal-open-stderr)) + ((eq face 'portal-exited-stderr-face) + (portal-open-stderr)) + ((eq face 'portal-stdout-face) + (portal-open-stdout)) + ((eq face 'portal-exited-stdout-face) + (portal-open-stdout)) + (t (call-interactively 'newline)))))