diff --git a/bin/doom b/bin/doom index 9550212a4..b2d94df93 100755 --- a/bin/doom +++ b/bin/doom @@ -1,25 +1,81 @@ #!/usr/bin/env sh :; set -e # -*- mode: emacs-lisp; lexical-binding: t -*- :; case "$EMACS" in *term*) EMACS=emacs ;; *) EMACS="${EMACS:-emacs}" ;; esac -:; $EMACS --version >/dev/null 2>&1 || { >&2 echo "Can't find emacs in your PATH"; exit 1; } -:; $EMACS --no-site-file --script "$0" -- "$@" || __DOOMCODE=$? -:; [ "${__DOOMCODE:-0}" -eq 128 ] && { sh "`$EMACS -Q --batch --eval '(princ temporary-file-directory)'`/doom.sh" "$0" "$@" && true; __DOOMCODE=$?; } -:; exit $__DOOMCODE +:; tmpdir=`$EMACS -Q --batch --eval '(princ (temporary-file-directory))' 2>/dev/null` +:; [ -z "$tmpdir" ] && { >&2 echo "Error: failed to run Emacs with command '$EMACS'"; >&2 echo; >&2 echo "Are you sure Emacs is installed and in your \$PATH?"; exit 1; } +:; export __DOOMPID="${__DOOMPID:-$$}" +:; export __DOOMSTEP="$((__DOOMSTEP+1))" +:; export __DOOMGEOM="${__DOOMGEOM:-`tput cols lines 2>/dev/null`}" +:; export __DOOMGPIPE=${__DOOMGPIPE:-$__DOOMPIPE} +:; export __DOOMPIPE=; [ -t 0 ] || __DOOMPIPE+=0; [ -t 1 ] || __DOOMPIPE+=1 +:; $EMACS -Q --batch --load "$0" -- "$@" || exit=$? +:; [ "${exit:-0}" -eq 254 ] && { sh "${tmpdir}/doom.${__DOOMPID}.${__DOOMSTEP}.sh" "$0" "$@" && true; exit="$?"; } +:; exit $exit -;; The garbage collector isn't as important during CLI ops. A higher threshold -;; makes it 15-30% faster, but set it too high and we risk runaway memory usage -;; in longer sessions. -(setq gc-cons-threshold 134217728) ; 128mb +;; This magical mess of a shebang is necessary for any script that relies on +;; Doom's CLI framework, because Emacs' tty libraries and capabilities are too +;; immature (borderline non-existent) at the time of writing (28.1). This +;; shebang sets out to accomplish these three goals: +;; +;; 1. To produce a more helpful error if Emacs isn't installed or broken. It +;; must do so without assuming whether $EMACS is a shell command (e.g. 'snap +;; run emacs') or an absolute path (to an emacs executable). I've avoided +;; 'command -v $EMACS' for this reason. +;; +;; 2. To allow this Emacs session to "exit into" a child process (since Elisp +;; lacks an analogue for exec system calls) by calling an auto-generated and +;; self-destructing "exit script" if the parent Emacs process exits with code +;; 254. It takes care to prevent nested child instances from clobbering the +;; exit script. +;; +;; 3. To expose some information about the terminal and session: +;; - $__DOOMGEOM holds the dimensions of the terminal (W . H). +;; - $__DOOMPIPE indicates whether the script has been piped (in and/or out). +;; - $__DOOMGPIPE indicates whether one of this process' parent has been +;; piped to/from. +;; - $__DOOMPID is a unique identifier for the parent script, so +;; child processes can identify which persistent data files (like logs) it +;; has access to. +;; - $__DOOMSTEP counts how many levels deep we are in the dream (appending +;; this to the exit script's filename avoids child processes clobbering the +;; same exit script and causing read errors). +;; - $TMPDIR (or $TEMP and $TMP on Windows) aren't guaranteed to have values, +;; and mktemp isn't available on all systems, but you know what is? Emacs! +;; So I use it to print `temporary-file-directory'. And it seconds as a +;; quick sanity check for Emacs' existence (for goal #1). +;; +;; Other weird facts about this shebang line: +;; +;; - The :; hack exploits properties of : and ; in shell scripting and elisp to +;; allow shell script and elisp to coexist in the same file without either's +;; interpreter throwing foreign syntax errors: +;; +;; - In elisp, ":" is a valid keyword symbol literal; it evaluates to itself +;; and has no side-effect. +;; - In the shell, ":" is a valid command that does nothing and ignores its +;; arguments. +;; - In elisp, ";" begins a comment. I.e. the interpreter ignores everything +;; after it. +;; - In the shell, ";" is a command separator. +;; +;; Put together, plus a strategically placed exit call, the shell will read +;; one part of this file and ignore the rest, while the elisp interpreter will +;; do the opposite. +;; - I intentionally avoid loading site files (using -Q), because +;; core/core-cli.el loads them by hand later. There, I can suppress and deal +;; with unhelpful warnings (e.g. "package cl is deprecated"), "Loading +;; X...DONE" spam, and any other disasterous side-effects. +;; - POSIX-compliancy is paramount: there's no guarantee what /bin/sh will be +;; symlinked to in the esoteric OSes/distros Emacs users use. +;; - The user may have a noexec flag set on /tmp, so pass the exit script to +;; /bin/sh rather than executing them directly. -;; Prioritize non-byte-compiled source files in non-interactive sessions to -;; prevent loading stale byte-code. -(setq load-prefer-newer t) - -;; Ensure Doom runs out of this file's parent directory, where Doom is -;; presumably installed. Use the EMACSDIR envvar to change this. +;; Ensure Doom runs out of this file's parent directory (or $EMACSDIR), where +;; Doom is presumably installed. (setq user-emacs-directory (if (getenv-internal "EMACSDIR") - (file-name-as-directory (expand-file-name (getenv-internal "EMACSDIR"))) + (file-name-as-directory + (file-truename (getenv-internal "EMACSDIR"))) (expand-file-name "../" (file-name-directory (file-truename load-file-name))))) @@ -27,140 +83,222 @@ ;; ;;; Sanity checks -(when (version< emacs-version "27.1") - (error - (concat "Detected Emacs " emacs-version " (at " (car command-line-args) ").\n\n" - "Doom only supports Emacs 27.1 and newer. A guide to install a newer version\n" - "of Emacs can be found at:\n\n " - (format "https://doomemacs.org/docs/getting_started.org#%s\n" - (cond ((eq system-type 'darwin) "on-macos") - ((memq system-type '(cygwin windows-nt ms-dos)) "on-windows") - ("on-linux"))) - "Aborting..."))) - -(unless (file-readable-p (expand-file-name "core/core.el" user-emacs-directory)) - (error - (concat - "Couldn't find or read '" - (abbreviate-file-name - (expand-file-name "core/core.el" user-emacs-directory)) - "'.\n\n" - "Are you sure Doom Emacs is correctly installed?\n\n" - (when (file-symlink-p load-file-name) - (concat "This error can occur if you've symlinked the 'doom' script, which Doom does not\n" - "support. Consider symlinking its parent directory instead or explicitly set the\n" - "EMACSDIR environment variable, e.g.\n\n " - (if (string-match-p "/fish$" (getenv "SHELL")) - "env EMACSDIR=~/.emacs.d doom" - "EMACSDIR=~/.emacs.d doom sync")) - "\n\n") - "Aborting..."))) - (when (equal (user-real-uid) 0) ;; If ~/.emacs.d is owned by root, assume the user genuinely wants root to be - ;; their primary user. + ;; their primary user, otherwise complain. (unless (= 0 (file-attribute-user-id (file-attributes user-emacs-directory))) - (error + (message (concat - "Do not run this script as root. It will cause file permissions errors later.\n\n" - "To carry on anyway, change the owner of your Emacs config to root:\n\n" + "Error: this script is being run as root, which is likely not what you want.\n" + "It will cause file permissions errors later, when you run Doom as another\n" + "user.\n\n" + "If this really *is* what you want, then change the owner of your Emacs\n" + "config to root:\n\n" + ;; TODO Add cmd.exe/powershell commands " chown root:root -R " (abbreviate-file-name user-emacs-directory) "\n\n" - "Aborting...")))) + "Aborting...")) + (kill-emacs 2))) ;; -;;; Let 'er rip! +;;; Load Doom's CLI framework -;; HACK Load `cl' and site files manually to prevent polluting logs and stdout -;; with deprecation and/or file load messages. -(let ((inhibit-message t)) - (require 'cl) - (unless site-run-file - (let ((site-run-file "site-start") - (verbose (or (getenv "DEBUG") init-file-debug)) - (tail load-path) - (lispdir (expand-file-name "../lisp" data-directory)) - dir) - (while tail - (setq dir (car tail)) - (let ((default-directory dir)) - (load (expand-file-name "subdirs.el") t (not verbose) t)) - (or (string-prefix-p lispdir dir) - (let ((default-directory dir)) - (load (expand-file-name "leim-list.el") t (not verbose) t))) - (setq tail (cdr tail))) - (load site-run-file t (not verbose))))) +(require 'core-cli (expand-file-name "core/core-cli" user-emacs-directory)) -;; Load the heart of the beast and its CLI processing library -(load (expand-file-name "core/core.el" user-emacs-directory) nil t) -(require 'core-cli) -(kill-emacs - ;; Process the arguments passed to this script. `doom-cli-execute' should - ;; return one of two things: a cons cell whose CAR is t, and CDR is the - ;; command's return value OR one of: a keyword, command string, or command - ;; list. - (pcase (apply #'doom-cli-execute :doom (cdr (member "--" argv))) +;; +;;; Entry point - ;; If a CLI command returns an integer, treat it as an exit code. - ((and (app car-safe `t) code) - (if (integerp (cdr code)) - (cdr code))) +(defcli! doom (&args _command) + "A command line interface to Doom Emacs. - ;; CLI commands can do (throw 'exit SHELL-COMMAND) to run something after - ;; this session ends. e.g. - ;; - ;; (throw 'exit "$@") or (throw 'exit :restart) - ;; This reruns the current command with the same arguments. - ;; (throw 'exit "$@ -h -c") - ;; This reruns the current command with two new switches. - ;; (throw 'exit "emacs -nw FILE") - ;; Opens Emacs on FILE - ;; (throw 'exit t) or (throw 'exit nil) - ;; A safe way to simply abort back to the shell with exit code 0 - ;; (throw 'exit 42) - ;; Abort to shell with an explicit exit code (as a more abrupt - ;; alternative to having the CLI command return 42). - ;; - ;; How this works: the command is written to a temporary shell script which - ;; is executed after this session ends (see the shebang lines of this file). - ;; It's done this way because Emacs' batch library lacks an implementation of - ;; the exec system call. - (command - (cond - ((integerp command) - command) - ((booleanp command) - 0) - ((let ((script (expand-file-name "doom.sh" temporary-file-directory)) - (coding-system-for-write 'utf-8-unix) - (coding-system-for-read 'utf-8-unix)) - (with-temp-file script - (insert "#!/usr/bin/env sh\n" - "_postscript() {\n" - " rm -f " (shell-quote-argument script) "\n " - (cond ((eq command :restart) "$@") - ((stringp command) command) - ((listp command) - (string-join - (if (listp (car-safe command)) - (cl-loop for line in (doom-enlist command) - collect (mapconcat #'shell-quote-argument (remq nil line) " ")) - (list (mapconcat #'shell-quote-argument (remq nil command) " "))) - "\n "))) - "\n}\n" - (save-match-data - (cl-loop for env - in (cl-set-difference process-environment - (get 'process-environment 'initial-value) - :test #'equal) - if (string-match "^\\([a-zA-Z0-9_]+\\)=\\(.+\\)$" env) - concat (format "%s=%s \\\n" - (match-string 1 env) - (shell-quote-argument (match-string 2 env))))) - (format "PATH=\"%s%s$PATH\" \\\n" (concat doom-emacs-dir "bin/") path-separator) - "_postscript $@\n")) - (set-file-modes script #o600) - ;; Error code 128 is special: it means run the post-script after this - ;; session ends. - 128)))))) +Includes package management, diagnostics, unit tests, and byte-compilation. + +This tool also makes it trivial to launch Emacs out of a different folder or +with a different private module. + +ENVIRONMENT VARIABLES: + `$EMACS' + The Emacs executable or command to use for any Emacs operations in this or + other Doom CLI shell scripts (default: first emacs found in `$PATH'). + + `$EMACSDIR' + The location of your Doom Emacs installation (defaults to ~/.config/emacs or + ~/.emacs.d; whichever is found first). This is *not* your private Doom + configuration. The `--emacsdir' option also sets this variable. + + `$DOOMDIR' + The location of your private configuration for Doom Emacs (defaults to + ~/.config/doom or ~/.doom.d; whichever it finds first). This is *not* the + place you've cloned doomemacs/doomemacs to. The `--doomdir' option also sets + this variable. + + `$DOOMPAGER' + The pager to invoke for large output (default: \"less +g\"). The `--pager' + option also sets this variable. + + `$DOOMPROFILE' + (Not implemented yet) Which Doom profile to activate (default: \"current\"). + + `$DOOMPROFILESDIR' + (Not implemented yet) Where to find or write generated Doom profiles + (default: `$EMACSDIR'/profiles). + +EXIT CODES: + 0 Successful run + 1 General internal error + 2 Error with Emacs/Doom install or execution context + 3 Unrecognized user input error + 4 Command not found, or is incorrect/deprecated + 5 Invalid, missing, or extra options/arguments + 6-49 Reserved for Doom + 50-200 Reserved for custom user codes + 254 Successful run (but then execute `doom-cli-restart-script') + 255 Uncaught internal errors + +SEE ALSO: + https://doomemacs.org Homepage + https://docs.doomemacs.org Official documentation + https://discourse.doomemacs.org Discourse (discussion & support forum) + https://doomemacs.org/discord Discord chat server + https://doomemacs.org/roadmap Development roadmap + https://git.doomemacs.org Shortcut to Github org + https://git.doomemacs.org/issues Global issue tracker" + :partial t) + +(defcli! (:before doom) + ((force? ("-!" "--force") "Suppress prompts by auto-accepting their consequences") + (debug? ("-D" "--debug") "Enable verbose output") + (doomdir ("--doomdir" dir) "Use Doom config living in `DIR' (e.g. ~/.doom.d)") + (emacsdir ("--emacsdir" dir) "Use Doom install living in `DIR' (e.g. ~/.emacs.d)") + (pager ("--pager" bool) "Pager command to use for large output") + ;; TODO Implement after v3.0 + ;; (profile ("--profile" name) "Use profile named NAME") + &flags + (color? ("--color") "Whether or not to show ANSI color codes") + &multiple + (loads ("-L" "--load" "--strict-load" file) "Load elisp `FILE' before executing `COMMAND'") + (evals ("-E" "--eval" form) "Evaluate `FORM' before executing commands") + &input input + &context context + &args _) + "OPTIONS: + -E, -eval + Can be used multiple times. + + -L, --load, --strict-load + Can be used multiple times to load multiple files. Both -L and --load will + silently fail on missing files, but --strict-load won't. + + Warning: files loaded this way load too late to define new commands. To + define commands, do so from `$DOOMDIR'/cli.el or `$DOOMDIR'/init.el + instead." + (when color? + (setq doom-print-backend (if (eq color? :yes) 'ansi))) + (when (and (equal (doom-cli-context-step context) 0) + (or ;; profile + debug? + force? + emacsdir + doomdir + pager)) + ;; TODO Implement after v3.0 + ;; (when profile + ;; (setenv "DOOMPROFILE" profile)) + (when debug? + (setenv "DEBUG" "1") + (print! (item "Debug mode enabled"))) + (when force? + (setenv "__DOOMFORCE" (and force? "1")) + (print! (item "Suppressing all prompts"))) + (when emacsdir + (setenv "EMACSDIR" emacsdir)) + (when doomdir + (setenv "DOOMDIR" doomdir)) + (when pager + (setenv "DOOMPAGER" pager)) + (exit! :restart)) + ;; Load $DOOMDIR/init.el, so users can customize things, if they like. + (doom-log "Loading $DOOMDIR/init.el") + (load! doom-module-init-file doom-private-dir t) + ;; Load extra files and forms, as per given options. + (dolist (file loads) + (load (doom-path (cdr file)) + (not (equal (car file) "--strict-load")) + (not doom-debug-p) t)) + (dolist (form evals) + (eval (read (cdr form)) t))) + + +;; +;;; Commands + +(let ((dir (doom-path doom-core-dir "cli"))) + ;; It'd be simple to just load these files directly, but because there could + ;; be a lot of them (and some of them have expensive dependencies), I use + ;; `defautoload!' to load them lazily. + (add-to-list 'doom-cli-load-path dir) + + ;; Library for generating autoloads files for Doom modules & packages. + (load! "autoloads" dir) + + (defgroup! + :prefix 'doom + ;; Import this for implicit 'X help' commands for your script: + (defalias! ((help h)) (:root :help)) + ;; And suggest its use when errors occur. + (add-to-list 'doom-help-commands "%p h[elp] %c") + + (defgroup! "Config Management" + :docs "Commands for maintaining your Doom Emacs configuration." + (defautoload! ((sync s))) + (defautoload! ((upgrade up))) + (defautoload! (env)) + (defautoload! ((build b purge p rollback)) "packages") + (defautoload! ((install i))) + (defautoload! ((compile c))) + + ;; TODO Post-3.0 commands + ;; (load! "gc" dir) + ;; (load! "module" dir) + ;; (load! "nuke" dir) + ;; (load! "package" dir) + ;; (load! "profile" dir) + ;; (defobsolete! ((compile c)) "doom sync --compile" "v3.0.0") + ;; (defobsolete! ((build b)) "doom sync --rebuild" "v3.0.0") + ) + + (defgroup! "Diagnostics" + :docs "Commands for troubleshooting and debugging Doom." + (defautoload! ((doctor doc))) + (defautoload! (info)) + (defalias! ((version v)) (:root :version))) + + (defgroup! "Development" + :docs "Commands for developing or launching Doom." + (defautoload! (ci)) + ;; TODO (defautoload! (make)) + (defautoload! (run)) + + ;; FIXME Test framework + ;; (load! "test" dir) + ) + + (let ((cli-file "cli")) + (defgroup! "Module commands" + (dolist (key (hash-table-keys doom-modules)) + (when-let* ((path (plist-get (gethash key doom-modules) path)) + (path (car (doom-glob path cli-file)))) + (defgroup! :prefix (format "+%s" (cdr key)) + (defautoload! () path))))) + + (doom-log "Loading $DOOMDIR/cli.el") + (load! cli-file doom-private-dir t)))) + + +;; +;;; Let 'er rip + +(run! "doom" (cdr (member "--" argv))) + +;;; doom ends here, unless... diff --git a/core/autoload/debug.el b/core/autoload/debug.el index 031558341..0573dc459 100644 --- a/core/autoload/debug.el +++ b/core/autoload/debug.el @@ -7,7 +7,9 @@ (defvar doom-debug-variables '(async-debug debug-on-error + (debugger . doom-debugger) doom-debug-p + (doom-print-level . debug) garbage-collection-messages gcmh-verbose init-file-debug @@ -67,6 +69,73 @@ symbol and CDR is the value to set it to when `doom-debug-mode' is activated.") (message "Debug mode %s" (if enabled "on" "off")))) +;; +;;; Custom debuggers + +(autoload 'backtrace-get-frames "backtrace") + +(defun doom-backtrace () + "Return a stack trace as a list of `backtrace-frame' objects." + ;; (let* ((n 0) + ;; (frame (backtrace-frame n)) + ;; (frame-list nil) + ;; (in-program-stack nil)) + ;; (while frame + ;; (when in-program-stack + ;; (push (cdr frame) frame-list)) + ;; (when (eq (elt frame 1) debugger) + ;; (setq in-program-stack t)) + ;; ;; (when (and (eq (elt frame 1) 'doom-cli-execute) + ;; ;; (eq (elt frame 2) :doom)) + ;; ;; (setq in-program-stack nil)) + ;; (setq n (1+ n) + ;; frame (backtrace-frame n))) + ;; (nreverse frame-list)) + (cdr (backtrace-get-frames debugger))) + +(defun doom-backtrace-write-to-file (backtrace file) + "Write BACKTRACE to FILE with appropriate boilerplate." + (make-directory (file-name-directory file) t) + (let ((doom-print-indent 0)) + (with-temp-file file + (insert ";; -*- lisp-interaction -*-\n") + (insert ";; vim: set ft=lisp:\n") + (insert (format ";; command=%S\n" command-line-args)) + (insert (format ";; date=%S\n\n" (format-time-string "%Y-%m-%d %H-%M-%S" before-init-time))) + (insert ";;;; ENVIRONMENT\n" (with-output-to-string (doom/version)) "\n") + (let ((standard-output (current-buffer)) + (print-quoted t) + (print-escape-newlines t) + (print-escape-control-characters t) + (print-symbols-bare t) + (print-level nil) + (print-circle nil) + (n -1)) + (mapc (lambda (frame) + (princ (format ";;;; %d\n" (cl-incf n))) + (pp (list (cons (backtrace-frame-fun frame) + (backtrace-frame-args frame)) + (backtrace-frame-locals frame))) + (terpri)) + backtrace)) + file))) + +(defun doom-debugger (&rest args) + "Enter `debugger' in interactive sessions, `doom-cli-debugger' otherwise. + +Writes backtraces to file and ensures the backtrace is recorded, so the user can +always access it." + (let ((backtrace (doom-backtrace))) + ;; Work around Emacs's heuristic (in eval.c) for detecting errors in the + ;; debugger, which would run this handler again on subsequent calls. Taken + ;; from `ert--run-test-debugger'. + (cl-incf num-nonmacro-input-events) + ;; TODO Write backtraces to file + ;; TODO Write backtrace to a buffer in case recursive error interupts the + ;; debugger (happens more often than it should). + (apply #'debug args))) + + ;; ;;; Time-stamped *Message* logs diff --git a/core/autoload/output.el b/core/autoload/output.el deleted file mode 100644 index 8c45c49ee..000000000 --- a/core/autoload/output.el +++ /dev/null @@ -1,278 +0,0 @@ -;;; core/autoload/output.el -*- lexical-binding: t; -*- - -(defvar doom-output-ansi-alist - '(;; fx - (bold 1 :weight bold) - (dark 2) - (italic 3 :slant italic) - (underscore 4 :underline t) - (blink 5) - (rapid 6) - (contrary 7) - (concealed 8) - (strike 9 :strike-through t) - ;; fg - (black 30 term-color-black) - (red 31 term-color-red) - (green 32 term-color-green) - (yellow 33 term-color-yellow) - (blue 34 term-color-blue) - (magenta 35 term-color-magenta) - (cyan 36 term-color-cyan) - (white 37 term-color-white) - ;; bg - (on-black 40 term-color-black) - (on-red 41 term-color-red) - (on-green 42 term-color-green) - (on-yellow 43 term-color-yellow) - (on-blue 44 term-color-blue) - (on-magenta 45 term-color-magenta) - (on-cyan 46 term-color-cyan) - (on-white 47 term-color-white)) - "An alist of fg/bg/fx names mapped to ansi codes and term-color-* variables. - -This serves as the cipher for converting (COLOR ...) function calls in `print!' -and `format!' into colored output, where COLOR is any car of this list.") - -(defvar doom-output-class-alist - `((color . doom--output-color) - (class . doom--output-class) - (indent . doom--output-indent) - (autofill . doom--output-autofill) - (success . (lambda (str &rest args) - (apply #'doom--output-color 'green (format "✓ %s" str) args))) - (warn . (lambda (str &rest args) - (apply #'doom--output-color 'yellow (format "! %s" str) args))) - (error . (lambda (str &rest args) - (apply #'doom--output-color 'red (format "x %s" str) args))) - (info . (lambda (str &rest args) - (concat "- " (if args (apply #'format str args) str)))) - (start . (lambda (str &rest args) - (concat "> " (if args (apply #'format str args) str)))) - (debug . (lambda (str &rest args) - (if doom-debug-p - (apply #'doom--output-color 'dark - (format "- %s" str) - args) - ""))) - (path . abbreviate-file-name) - (symbol . symbol-name) - (relpath . (lambda (str &optional dir) - (if (or (not str) - (not (stringp str)) - (string-empty-p str)) - str - (let ((dir (or dir (file-truename default-directory))) - (str (file-truename str))) - (if (file-in-directory-p str dir) - (file-relative-name str dir) - (abbreviate-file-name str)))))) - (filename . file-name-nondirectory) - (dirname . (lambda (path) - (unless (file-directory-p path) - (setq path (file-name-directory path))) - (directory-file-name path)))) - "An alist of text classes that map to transformation functions. - -Any of these classes can be called like functions from within `format!' and -`print!' calls, which will transform their input.") - -(defvar doom-output-indent 0 - "Level to rigidly indent text returned by `format!' and `print!'.") - -(defvar doom-output-indent-increment 2 - "Steps in which to increment `doom-output-indent' for consecutive levels.") - -(defvar doom-output-backend - (if doom-interactive-p 'text-properties 'ansi) - "Determines whether to print colors with ANSI codes or with text properties. - -Accepts 'ansi and 'text-properties. nil means don't render colors.") - - -;; -;;; Library - -;;;###autoload -(defun doom--format (output) - (if (string-empty-p (string-trim output)) - "" - (concat (make-string doom-output-indent 32) - (replace-regexp-in-string - "\n" (concat "\n" (make-string doom-output-indent 32)) - output t t)))) - -;;;###autoload -(defun doom--print (output) - (unless (string-empty-p output) - (if noninteractive - (send-string-to-terminal output) - (princ output)) - (terpri) - output)) - -;;;###autoload -(defun doom--output-indent (width text &optional prefix) - "Indent TEXT by WIDTH spaces. If ARGS, format TEXT with them." - (with-temp-buffer - (setq text (format "%s" text)) - (insert text) - (indent-rigidly (point-min) (point-max) width) - (when (stringp prefix) - (when (> width 2) - (goto-char (point-min)) - (beginning-of-line-text) - (delete-char (- (length prefix))) - (insert prefix))) - (buffer-string))) - -;;;###autoload -(defun doom--output-autofill (&rest msgs) - "Ensure MSG is split into lines no longer than `fill-column'." - (with-temp-buffer - (let ((fill-column 76)) - (dolist (line msgs) - (when line - (insert (format "%s" line)))) - (fill-region (point-min) (point-max)) - (buffer-string)))) - -;;;###autoload -(defun doom--output-color (style format &rest args) - "Apply STYLE to formatted MESSAGE with ARGS. - -STYLE is a symbol that correlates to `doom-output-ansi-alist'. - -In a noninteractive session, this wraps the result in ansi color codes. -Otherwise, it maps colors to a term-color-* face." - (let* ((code (cadr (assq style doom-output-ansi-alist))) - (format (format "%s" format)) - (message (if args (apply #'format format args) format))) - (unless code - (error "%S is an invalid color" style)) - (pcase doom-output-backend - (`ansi - (format "\e[%dm%s\e[%dm" code message 0)) - (`text-properties - (require 'term) ; piggyback on term's color faces - (propertize - message - 'face - (append (get-text-property 0 'face format) - (cond ((>= code 40) - `(:background ,(caddr (assq style doom-output-ansi-alist)))) - ((>= code 30) - `(:foreground ,(face-foreground (caddr (assq style doom-output-ansi-alist))))) - ((cddr (assq style doom-output-ansi-alist))))))) - (_ message)))) - -;;;###autoload -(defun doom--output-class (class format &rest args) - "Apply CLASS to formatted format with ARGS. - -CLASS is derived from `doom-output-class-alist', and can contain any arbitrary, -transformative logic." - (let (fn) - (cond ((setq fn (cdr (assq class doom-output-class-alist))) - (if (functionp fn) - (apply fn format args) - (error "%s does not have a function" class))) - (args (apply #'format format args)) - (format)))) - -;;;###autoload -(defun doom--output-apply (forms &optional sub) - "Replace color-name functions with calls to `doom--output-color'." - (cond ((null forms) nil) - ((listp forms) - (append (cond ((not (symbolp (car forms))) - (list (doom--output-apply (car forms)))) - (sub - (list (car forms))) - ((assq (car forms) doom-output-ansi-alist) - `(doom--output-color ',(car forms))) - ((assq (car forms) doom-output-class-alist) - `(doom--output-class ',(car forms))) - ((list (car forms)))) - (doom--output-apply (cdr forms) t) - nil)) - (forms))) - -;;;###autoload -(defmacro format! (message &rest args) - "An alternative to `format' that understands (color ...) and converts them -into faces or ANSI codes depending on the type of sesssion we're in." - `(doom--format (format ,@(doom--output-apply `(,message ,@args))))) - -;;;###autoload -(defmacro print-group! (&rest body) - "Indents any `print!' or `format!' output within BODY." - `(let ((doom-output-indent (+ doom-output-indent-increment doom-output-indent))) - ,@body)) - -;;;###autoload -(defmacro print! (message &rest args) - "Prints MESSAGE, formatted with ARGS, to stdout. - -Returns non-nil if the message is a non-empty string. - -Can be colored using (color ...) blocks: - - (print! \"Hello %s\" (bold (blue \"How are you?\"))) - (print! \"Hello %s\" (red \"World\")) - (print! (green \"Great %s!\") \"success\") - -Uses faces in interactive sessions and ANSI codes otherwise." - `(doom--print (format! ,message ,@args))) - -;;;###autoload -(defmacro insert! (message &rest args) - "Like `insert'; the last argument must be format arguments for MESSAGE. - -\(fn MESSAGE... ARGS)" - `(insert (format! (concat ,message ,@(butlast args)) - ,@(car (last args))))) - -;;;###autoload -(defmacro error! (message &rest args) - "Like `error', but with the power of `format!'." - `(error (format! ,message ,@args))) - -;;;###autoload -(defmacro user-error! (message &rest args) - "Like `user-error', but with the power of `format!'." - `(user-error (format! ,message ,@args))) - -;;;###autoload -(defmacro with-output-to! (dest &rest body) - "Send all output produced in BODY to DEST. -DEST can be one or more of `standard-output', a buffer, a file" - (declare (indent 1)) - `(let* ((log-buffer (generate-new-buffer " *doom log*")) - (standard-output - (lambda (out) - (with-current-buffer log-buffer - (insert-char out)) - (send-string-to-terminal (char-to-string out))))) - (letf! (defun message (msg &rest args) - (when msg - (print-group! - (with-current-buffer log-buffer - (insert (doom--format (apply #'format msg args)) "\n")) - (when (or doom-debug-p (not inhibit-message)) - (doom--print (doom--format (apply #'format msg args)))))) - message) - (unwind-protect - ,(macroexp-progn body) - (with-current-buffer log-buffer - (require 'ansi-color) - (ansi-color-filter-region (point-min) (point-max))) - (let ((dest ,dest)) - (cond ((bufferp dest) - (with-current-buffer dest - (insert-buffer-substring log-buffer))) - ((stringp dest) - (make-directory (file-name-directory dest) 'parents) - (with-temp-file dest - (insert-buffer-substring log-buffer)))) - (kill-buffer log-buffer)))))) diff --git a/core/autoload/print.el b/core/autoload/print.el new file mode 100644 index 000000000..a4d9099ce --- /dev/null +++ b/core/autoload/print.el @@ -0,0 +1,473 @@ +;;; core/autoload/print.el -*- lexical-binding: t; -*- +;;; Commentary +;;; +;;; This is Doom's output library, for controlling what does and doesn't get +;;; logged, and provides a simple DSL for formatting output. It's mainly to +;;; serve the noninteractive use-case, as `message' is more than good enough in +;;; interactive sessions, but `print!' and `doom-log' are safe to use as a +;;; drop-in replacement. +;;; +;;; Code: + +(require 'ansi-color) + +(defvar doom-print-ansi-alist + '(;; fx + (bold 1 :weight bold) + (dark 2) + (italic 3 :slant italic) + (underscore 4 :underline t) + (blink 5) + (rapid 6) + (contrary 7) + (concealed 8) + (strike 9 :strike-through t) + ;; fg + (black 30 term-color-black) + (red 31 term-color-red) + (green 32 term-color-green) + (yellow 33 term-color-yellow) + (blue 34 term-color-blue) + (magenta 35 term-color-magenta) + (cyan 36 term-color-cyan) + (white 37 term-color-white) + ;; bg + (on-black 40 term-color-black) + (on-red 41 term-color-red) + (on-green 42 term-color-green) + (on-yellow 43 term-color-yellow) + (on-blue 44 term-color-blue) + (on-magenta 45 term-color-magenta) + (on-cyan 46 term-color-cyan) + (on-white 47 term-color-white)) + "An alist of fg/bg/fx names mapped to ansi codes and term-color-* variables. + +This serves as the cipher for converting (COLOR ...) function calls in `print!' +and `format!' into colored output, where COLOR is any car of this list.") + +(defvar doom-print-class-alist + `((buffer . doom-print--buffer) + (color . doom-print--style) + (class . doom-print--class) + (indent . doom-print--indent) + (fill . doom-print--fill) + (join . doom-print--join) + (org . doom-print--org) + (markup . doom-print--cli-markup) + (trim . string-trim) + (rtrim . string-trim-right) + (ltrim . string-trim-left) + (p . doom-print--paragraph) + (buffer . (lambda (buffer) + (with-current-buffer buffer + (buffer-string)))) + (truncate . doom-print--truncate) + (success . (lambda (str &rest args) + (apply #'doom-print--style 'green + (doom-print--indent str "✓ ") + args))) + (warn . (lambda (str &rest args) + (apply #'doom-print--style 'yellow + (doom-print--indent str "! ") + args))) + (error . (lambda (str &rest args) + (apply #'doom-print--style 'red + (doom-print--indent str "x ") + args))) + (item . (lambda (str &rest args) + (doom-print--indent + (if args (apply #'format str args) str) + "- "))) + (start . (lambda (str &rest args) + (doom-print--indent + (if args (apply #'format str args) str) + "> "))) + (path . abbreviate-file-name) + (symbol . symbol-name) + (relpath . (lambda (str &optional dir) + (if (or (not str) + (not (stringp str)) + (string-blank-p str)) + str + (let ((dir (or dir (file-truename default-directory))) + (str (file-truename str))) + (if (file-in-directory-p str dir) + (file-relative-name str dir) + (abbreviate-file-name str)))))) + (filename . file-name-nondirectory) + (dirname . (lambda (path) + (unless (file-directory-p path) + (setq path (file-name-directory path))) + (directory-file-name path)))) + "An alist of text classes that map to transformation functions. + +Any of these classes can be called like functions from within `format!' and +`print!' calls, which will transform their input.") + +(defvar doom-print-indent 0 + "Level to rigidly indent text returned by `format!' and `print!'.") + +(defvar doom-print-indent-increment 2 + "Steps in which to increment `doom-print-indent' for consecutive levels.") + +(defvar doom-print-backend + (if doom-interactive-p 'text-properties 'ansi) + "Whether to print colors/styles with ANSI codes or with text properties. + +Accepts `ansi' and `text-properties'. `nil' means don't render styles at all.") + +(defvar doom-print-level (if doom-debug-p 'debug 'info) + "The default level of messages to print.") + +(defvar doom-print-logging-level 'debug + "The default logging level used by `doom-log'/`doom-print'.") + +(defvar doom-print-message-level (if noninteractive 'debug 'info) + "The default logging level used by `message'.") + +(defvar doom-print--levels + '(debug ; the system is thinking out loud + info ; a FYI; to keep you posted + warning ; a dismissable issue that may have reprecussions later + error)) ; functionality has been disabled by misbehavior + +(dotimes (i (length doom-print--levels)) + (put (nth i doom-print--levels) 'level i)) + + +;; +;;; Library + +;;;###autoload +(cl-defun doom-print + (output &key + (format t) + (newline t) + (stream standard-output) + (level doom-print-level)) + "Print OUTPUT to stdout. + +Unlike `message', this: +- Respects `standard-output'. +- Respects `doom-print-indent' (if FORMAT) +- Prints to stdout instead of stderr in batch mode. +- Respects more ANSI codes (only in batch mode). +- No-ops if OUTPUT is nil or an empty/blank string. + +Returns OUTPUT." + (cl-check-type output (or null string)) + (when (and (stringp output) + (not (string-blank-p output)) + (or (eq level t) + (>= (get level 'level) + (get doom-print-level 'level)))) + (let ((output (if format + (doom-print--format "%s" output) + output))) + (princ output stream) + (if newline (terpri stream)) + output))) + +;;;###autoload +(progn + ;; Autoload whole definition, so its buried uses don't pull in this whole file + ;; with them at expansion time. + (defmacro doom-log (output &rest args) + "Log a message in *Messages*. + +Does not emit the message in the echo area. This is a macro instead of a +function to prevent the potentially expensive execution of its arguments when +debug mode is off." + `(when (or doom-debug-p (not doom-interactive-p)) + (let ((inhibit-message t)) + (message + "%s" (propertize + (doom-print--format + (format + "* [%s] %s" + ,(let ((time `(format "%.06f" (float-time (time-subtract (current-time) before-init-time))))) + (cond (noninteractive time) + ((bound-and-true-p doom--current-module) + (format "[:%s %s] " + (doom-keyword-name (car doom--current-module)) + (cdr doom--current-module))) + ((when-let (file (ignore-errors (file!))) + (format "[%s] " + (file-relative-name + file (doom-path (file-name-directory file) "../"))))) + (time))) + ,output) + ,@args) + 'face 'font-lock-doc-face)))))) + +;;;###autoload +(defmacro format! (message &rest args) + "An alternative to `format' that understands (color ...) and converts them +into faces or ANSI codes depending on the type of sesssion we're in." + `(doom-print--format ,@(doom-print--apply `(,message ,@args)))) + +;;;###autoload +(defmacro print-group! (&rest body) + "Indents any `print!' or `format!' output within BODY." + `(print-group-if! t ,@body)) + +;;;###autoload +(defmacro print-group-if! (condition &rest body) + "Indents any `print!' or `format!' output within BODY." + (declare (indent 1)) + `(let ((doom-print-indent + (+ (if ,condition doom-print-indent-increment 0) + doom-print-indent))) + ,@body)) + +;;;###autoload +(defmacro print! (message &rest args) + "Prints MESSAGE, formatted with ARGS, to stdout. + +Returns non-nil if the message is a non-empty string. + +Can be colored using (color ...) blocks: + + (print! \"Hello %s\" (bold (blue \"How are you?\"))) + (print! \"Hello %s\" (red \"World\")) + (print! (green \"Great %s!\") \"success\") + +Uses faces in interactive sessions and ANSI codes otherwise." + `(doom-print (format! ,message ,@args) :format nil)) + +;;;###autoload +(defmacro insert! (&rest args) + "Like `insert', but with the power of `format!'. + +Each argument in ARGS can be a list, as if they were arguments to `format!': +\(MESSAGE [ARGS...]). + +\(fn &rest (MESSAGE . ARGS)...)" + `(insert ,@(cl-loop for arg in args + if (listp arg) + collect `(format! ,@arg) + else collect arg))) + + +;; +;;; Helpers + +;;;###autoload +(defun doom-print--format (message &rest args) + (if (or (null message) (string-blank-p message)) + "" + (concat (make-string doom-print-indent 32) + (replace-regexp-in-string + "\n" (concat "\n" (make-string doom-print-indent 32)) + (if args (apply #'format message args) message) + t t)))) + +;;;###autoload +(defun doom-print--indent (text &optional prefix) + "Indent TEXT by WIDTH spaces. If ARGS, format TEXT with them." + (with-temp-buffer + (let ((width + (cond ((null prefix) + doom-print-indent-increment) + ((integerp prefix) + prefix) + ((length (ansi-color-filter-apply (format "%s" prefix))))))) + (insert (format "%s" (or text ""))) + (indent-rigidly (point-min) (point-max) width) + (when (stringp prefix) + (goto-char (point-min)) + (delete-char width) + (insert prefix)) + (buffer-string)))) + +;;;###autoload +(defun doom-print--fill (message &optional column indent) + "Ensure MSG is split into lines no longer than `fill-column'." + (with-temp-buffer + (let* ((fill-column (or column fill-column)) + (col 0) + (indent (or indent 0)) + (fill-prefix (make-string indent ?\s))) + (save-excursion + (insert (format "%s" (or message "")))) + ;; HACK This monkey patches `fill-region' to not count ANSI codes as + ;; legitimate characters, when calculating per-line `fill-column'. + (letf! (defun current-fill-column () + (let ((target (funcall current-fill-column))) + (save-excursion + (goto-char (line-beginning-position)) + (let ((n 0) + (c 0)) + (while (and (not (eolp)) (<= n target)) + (save-match-data + (if (looking-at ansi-color--control-seq-fragment-regexp) + (let ((len (length (match-string 0)))) + (cl-incf c len) + (forward-char len)) + (cl-incf n 1) + (forward-char 1)))) + (+ target c (length fill-prefix)))))) + (fill-region (point-min) (point-max) nil t)) + (buffer-string)))) + +;;;###autoload +(defun doom-print--paragraph (&rest lines) + "TODO" + (doom-print--fill (apply #'concat lines))) + +;;;###autoload +(defun doom-print--join (sequence &optional separator) + "Ensure SEQUENCE is joined with SEPARATOR. + +`nil' and empty strings in SEQUENCE are omitted." + (mapconcat (doom-partial #'format "%s") + (seq-remove (fn!! (or (null %) + (and (stringp %) + (string-empty-p %)))) + sequence) + (or separator " "))) + +;;;###autoload +(defun doom-print--truncate (text &optional col ellipsis) + "Replaces basic org markup with ansi/text-properties." + (truncate-string-to-width (or text "") (or col (- fill-column doom-print-indent)) + nil nil (or ellipsis "..."))) + +;;;###autoload +(defun doom-print--buffer (buffer &optional beg end) + "Replaces basic org markup with ansi/text-properties." + (if (and (bufferp buffer) (buffer-live-p buffer)) + (with-current-buffer buffer + (if (or beg end) + (buffer-substring (or beg (point-min)) + (or end (point-max))) + (buffer-string))) + "")) + +;;;###autoload +(defun doom-print--cli-markup (text) + "Replace `...', `...`, and ```...``` quotes in TEXT with CLI formatting. + +- `$ENVVAR' = bolded +- `--switch' = bolded +- `ARG' = underlined +- `symbol' = highlighted in blue +- `arbitrary code` = highlighted in blue +- ``` + Arbitrary multiline code gets highlighted in blue too. + ```" + (if (not text) "" + (let ((case-fold-search nil)) + ;; TODO Syntax highlighting? + (replace-regexp-in-string + " *```\n\\(.+?\\)\n *```" (doom-print--style 'blue "%s" "\\1") + (replace-regexp-in-string + "`\\$ \\([^`\n]+?\\)`" (format "`%s`" (doom-print--style 'blue "%s" "\\1")) + (replace-regexp-in-string + "`\\([^ \n]+?\\)'" + (let ((styles '(("^\\$" . envvar) + ("^--?" . option) + ("^[A-Z][A-Z0-9-_]*$" . arg) + ("." . symbol)))) + (lambda (match) + (let ((text (match-string 1 match))) + (pcase (assoc-default text styles #'string-match-p) + (`arg (doom-print--style 'underscore "%s" text)) + (`envvar (doom-print--style 'bold "%s" text)) + (`option (doom-print--style 'bold "%s" text)) + (_ (format "`%s'" (doom-print--style 'blue "%s" text))))))) + text t) + t) + t)))) + +;;;###autoload +(defun doom-print--org (text) + "Replaces basic Org markup with ansi/text-properties. + +All emphasis markers need to be preceded by a backslash." + (let* ((inhibit-modification-hooks t) + (styles '((?* . bold) + (?_ . underscore) + (?/ . italic) + (?= . magenta) + (?+ . strike) + (?~ . blue))) + (fences (regexp-quote (mapconcat #'char-to-string (mapcar #'car styles) "")))) + (with-temp-buffer + (save-excursion (insert text)) + (while (re-search-forward (format "\\([%s]\\)" fences) nil t) + (unless (= (char-before (match-beginning 0)) ?\\) + (let* ((beg (match-beginning 0)) + (ibeg (point)) + (fence (match-string 1)) + (fence-re (regexp-quote fence))) + (when (re-search-forward (format "[^\\]%s" fence-re) (line-end-position 2) t) + (let ((end (point)) + (iend (1- (point)))) + (let ((text (buffer-substring ibeg iend))) + (when-let (style (cdr (assq (string-to-char fence) styles))) + (goto-char beg) + (delete-region beg end) + (insert (doom-print--style style "%s" text))))) + (goto-char beg))))) + (buffer-string)))) + +;;;###autoload +(defun doom-print--style (style format &rest args) + "Apply STYLE to formatted MESSAGE with ARGS. + +STYLE is a symbol that correlates to `doom-print-ansi-alist'. + +In a noninteractive session, this wraps the result in ansi color codes. +Otherwise, it maps colors to a term-color-* face." + (let* ((code (cadr (assq style doom-print-ansi-alist))) + (format (format "%s" (or format ""))) + (message (if args (apply #'format format args) format))) + (unless code + (error "Invalid print style: %s" style)) + (pcase doom-print-backend + (`ansi + (format "\e[0%dm%s\e[%dm" code message 0)) + (`text-properties + (require 'term) ; piggyback on term's color faces + (propertize + message + 'face + (append (get-text-property 0 'face format) + (cond ((>= code 40) + `(:background ,(caddr (assq style doom-print-ansi-alist)))) + ((>= code 30) + `(:foreground ,(face-foreground (caddr (assq style doom-print-ansi-alist))))) + ((cddr (assq style doom-print-ansi-alist))))))) + (_ message)))) + +;;;###autoload +(defun doom-print--class (class format &rest args) + "Apply CLASS to formatted format with ARGS. + +CLASS is derived from `doom-print-class-alist', and can contain any arbitrary, +transformative logic." + (let (fn) + (cond ((setq fn (cdr (assq class doom-print-class-alist))) + (if (functionp fn) + (apply fn format args) + (error "%s does not have a function" class))) + (args (apply #'format format args)) + (format)))) + +(defun doom-print--apply (forms &optional sub) + "Replace color-name functions with calls to `doom-print--style'." + (cond ((null forms) nil) + ((listp forms) + (append (cond ((not (symbolp (car forms))) + (list (doom-print--apply (car forms)))) + (sub + (list (car forms))) + ((assq (car forms) doom-print-ansi-alist) + `(doom-print--style ',(car forms))) + ((assq (car forms) doom-print-class-alist) + `(doom-print--class ',(car forms))) + ((list (car forms)))) + (doom-print--apply (cdr forms) t) + nil)) + (forms))) diff --git a/core/cli/autoloads.el b/core/cli/autoloads.el index 7053fa4e3..4cad1a251 100644 --- a/core/cli/autoloads.el +++ b/core/cli/autoloads.el @@ -30,6 +30,9 @@ one wants that.") (defun doom-autoloads-reload (&optional file) "Regenerates Doom's autoloads and writes them to FILE." (unless file + ;; TODO Uncomment when profile system is implemented + ;; (make-directory doom-profile-dir t) + ;; (setq file (expand-file-name "init.el" doom-profile-dir)) (setq file doom-autoloads-file)) (print! (start "(Re)generating autoloads file...")) (print-group! @@ -59,7 +62,10 @@ one wants that.") (seq-difference (hash-table-keys straight--build-cache) doom-autoloads-excluded-packages)) doom-autoloads-excluded-files - 'literal)) + 'literal) + ;; TODO Uncomment when profile system is implemented + ;; `((if doom-interactive-p (require 'core-start))) + ) (print! (start "Byte-compiling autoloads file...")) (doom-autoloads--compile-file file) (print! (success "Generated %s") @@ -128,10 +134,10 @@ one wants that.") (cond ((and (not module-enabled-p) altform) (print (read altform))) ((memq definer '(defun defmacro cl-defun cl-defmacro)) - (if module-enabled-p - (print (make-autoload form file)) - (cl-destructuring-bind (_ _ arglist &rest body) form - (print + (print + (if module-enabled-p + (make-autoload form file) + (seq-let (_ _ arglist &rest body) form (if altform (read altform) (append @@ -141,21 +147,20 @@ one wants that.") (_ type)) symbol arglist (format "THIS FUNCTION DOES NOTHING BECAUSE %s IS DISABLED\n\n%s" - module - (if (stringp (car body)) - (pop body) - "No documentation."))) + module (if (stringp (car body)) + (pop body) + "No documentation."))) (cl-loop for arg in arglist - if (and (symbolp arg) - (not (keywordp arg)) - (not (memq arg cl--lambda-list-keywords))) + if (symbolp arg) + if (not (keywordp arg)) + if (not (memq arg cl--lambda-list-keywords)) collect arg into syms else if (listp arg) collect (car arg) into syms finally return (if syms `((ignore ,@syms))))))))) (print `(put ',symbol 'doom-module ',module))) ((eq definer 'defalias) - (cl-destructuring-bind (_ _ target &optional docstring) form + (seq-let (_ _ target docstring) form (unless module-enabled-p (setq target #'ignore docstring @@ -176,7 +181,7 @@ one wants that.") ;; the autoloads file. debug-on-error ;; Non-nil interferes with autoload generation in Emacs < 29. See - ;; raxod502/straight.el#904. + ;; radian-software/straight.el#904. (left-margin 0) ;; The following bindings are in `package-generate-autoloads'. ;; Presumably for a good reason, so I just copied them. diff --git a/core/cli/ci.el b/core/cli/ci.el index b26fa68cc..571cb28d4 100644 --- a/core/cli/ci.el +++ b/core/cli/ci.el @@ -1,60 +1,9 @@ ;;; core/cli/ci.el -*- lexical-binding: t; -*- -(defcli! ci (&optional target &rest args) - "TODO" - (unless target - (user-error "No CI target given")) - (when-let* ((ci-dir - (or (locate-dominating-file default-directory ".github/ci.el") - doom-private-dir)) - (ci-config - (car (or (doom-glob ci-dir ".github/ci.el") - (doom-glob ci-dir "ci.el") - (doom-glob ci-dir "cli.el"))))) - (print! (info "Loading %s") (path ci-config)) - (load ci-config nil t t)) - (if-let (fn (intern-soft (format "doom-cli--ci-%s" target))) - (apply fn args) - (user-error "No known CI target: %S" target))) - - ;; -;;; +;;; Variables - -(defun doom-cli--ci-deploy-hooks (&optional force) - (let* ((repo-path (cdr (doom-call-process "git" "rev-parse" "--show-toplevel"))) - (submodule-p (string-empty-p (cdr (doom-call-process "git" "rev-parse" "show-superproject-working-tree")))) - (config-hooks-path (cdr (doom-call-process "git" "config" "core.hooksPath"))) - (hooks-path (cdr (doom-call-process "git" "rev-parse" "--git-path" "hooks")))) - (unless (string-empty-p config-hooks-path) - (or force - (y-or-n-p - (format (concat "Detected non-standard core.hookPath: %S\n\n" - "Install Doom's commit-msg and pre-push git hooks anyway?") - hooks-path)) - (user-error "Aborted"))) - (make-directory hooks-path 'parents) - (print! (start "Deploying git hooks in %S") (path hooks-path)) - (print-group! - (dolist (hook '("commit-msg" "pre-push")) - (let* ((hook (doom-path hooks-path hook)) - (overwrite-p (file-exists-p hook))) - (with-temp-file hook - (insert "#!/usr/bin/env sh\n" - (doom-path doom-emacs-dir "bin/doom") - " --nocolor ci hook-" (file-name-base hook) - " \"$@\"")) - (set-file-modes hook #o700) - (print! (success "%s %s") - (if overwrite-p "Overwrote" "Created") - (path hook))))))) - - -;; -;;; Git hooks - -(defvar doom-cli-commit-trailer-keys +(defvar doom-ci-commit-trailer-keys '(("Fix" ref hash url) ("Ref" ref hash url) ("Close" ref) @@ -66,7 +15,7 @@ Accapted value types can be one or more of ref, hash, url, username, or name.") -(defvar doom-cli-commit-trailer-types +(defvar doom-ci-commit-trailer-types '((ref . "^\\(https?://[^ ]+\\|[^/]+/[^/]+\\)?#[0-9]+$") (hash . "^\\(https?://[^ ]+\\|[^/]+/[^/]+@\\)?[a-z0-9]\\{12\\}$") (url . "^https?://") @@ -76,17 +25,17 @@ Accapted value types can be one or more of ref, hash, url, username, or name.") Accapted value types can be one or more of ref, hash, url, username, or name.") -(defvar doom-cli-commit-types +(defvar doom-ci-commit-types '(bump dev docs feat fix merge nit perf refactor release revert test tweak) "A list of valid commit types.") -(defvar doom-cli-commit-scopeless-types '(bump merge release revert) +(defvar doom-ci-commit-scopeless-types '(bump merge release revert) "A list of commit types whose scopes should be passed in its BODY. Don't: \"bump(SCOPE): ...\" Do: \"bump: SCOPE\"") -(defvar doom-cli-commit-scopes '("ci" doom-cli-enforce-scopeless-types) +(defvar doom-ci-commit-scopes '("ci" doom-ci-enforce-scopeless-types) "A list of valid commit scopes as strings, predicate functions, or lists. These are checked against each item in the comma-delimited scope field of the @@ -96,7 +45,7 @@ Each element of this list can be one of: - A string, compared literally against the scope's name. - A function predicate, taking two arguments (a scope as a symbol, and a plist - containing information about the current commit--see `doom-cli-commit-scopes' + containing information about the current commit--see `doom-ci-commit-scopes' for more about its structure). These predicates should: - Return non-nil to immediately pass a scope. - Throw a `user-error' to immediately fail the scope. @@ -106,13 +55,7 @@ Each element of this list can be one of: '(docs \"faq\" \"install\" check-docs)") -(cl-defun doom-cli-enforce-scopeless-types (scope (&key type scopes summary &allow-other-keys)) - "Complain about scoped types that are incompatible with scopes" - (when (memq type doom-cli-commit-scopeless-types) - (user-error "Scopes for %s commits should go after the colon, not before" - type))) - -(defvar doom-cli-commit-rules +(defvar doom-ci-commit-rules ;; TODO Extract into named functions (list (fn! (&key subject) "If a fixup/squash commit, don't lint this commit" @@ -136,7 +79,7 @@ Each element of this list can be one of: (fn! (&key type) "Ensure commit has valid type" - (or (memq type doom-cli-commit-types) + (or (memq type doom-ci-commit-types) (if type (fail! "Invalid commit type: %s" type) (fail! "Commit has no detectable type")))) @@ -166,7 +109,7 @@ Each element of this list can be one of: (and (listp rule) (eq type (car rule)) (seq-find #'check-rule (cdr rule))))) - (or (seq-find #'check-rule doom-cli-commit-scopes) + (or (seq-find #'check-rule doom-ci-commit-scopes) (fail! "Invalid scope: %s" scope))) (user-error (fail! "%s" (error-message-string e)))))) @@ -228,7 +171,7 @@ Each element of this list can be one of: ;; TODO Add bump validations for revert: type. (fn! (&key body trailers) "Validate commit trailers." - (let* ((keys (mapcar #'car doom-cli-commit-trailer-keys)) + (let* ((keys (mapcar #'car doom-ci-commit-trailer-keys)) (key-re (regexp-opt keys t)) (lines ;; Scan BODY because invalid trailers won't be in TRAILERS. @@ -250,13 +193,13 @@ Each element of this list can be one of: (truncate-string-to-width (string-trim line) 16 nil nil "…") (match-string 1 line)))) (pcase-dolist (`(,key . ,value) trailers) - (if (and (not (memq 'name (cdr (assoc key doom-cli-commit-trailer-keys)))) + (if (and (not (memq 'name (cdr (assoc key doom-ci-commit-trailer-keys)))) (string-match-p " " value)) (fail! "Found %S, but only one value allowed per trailer" (truncate-string-to-width (concat key ": " value) 20 nil nil "…")) - (when-let (allowed-types (cdr (assoc key doom-cli-commit-trailer-keys))) + (when-let (allowed-types (cdr (assoc key doom-ci-commit-trailer-keys))) (or (cl-loop for type in allowed-types - if (cdr (assq type doom-cli-commit-trailer-types)) + if (cdr (assq type doom-ci-commit-trailer-types)) if (string-match-p it value) return t) (fail! "%S expects one of %s, but got %S" @@ -299,18 +242,98 @@ as `format'. Note: warnings are not considered failures.") -(defun doom-cli--ci-hook-commit-msg (file) + +;; +;;; Commands + +;;; doom ci +(defcli! (:before ci) (&rest _) + (when-let* + ((repo-root (or (cdr (doom-call-process "git" "rev-parse" "--show-toplevel")) + default-directory)) + (local-config + (car (or (doom-glob repo-root "ci.el") + (doom-glob doom-private-dir "ci.el"))))) + (print! (item "Loading %s") (path local-config)) + (load local-config nil t t))) + +(defcli! ci () + "Commands that automate development processes." + :partial t) + +(defcli! (ci deploy-hooks) ((force ("--force"))) + "TODO" + (let* ((default-directory doom-emacs-dir) + (repo-path (cdr (doom-call-process "git" "rev-parse" "--show-toplevel"))) + (submodule-p (string-empty-p (cdr (doom-call-process "git" "rev-parse" "show-superproject-working-tree")))) + (config-hooks-path (cdr (doom-call-process "git" "config" "core.hooksPath"))) + (hooks-path (cdr (doom-call-process "git" "rev-parse" "--git-path" "hooks")))) + (unless (string-empty-p config-hooks-path) + (or force + (y-or-n-p + (format (concat "Detected non-standard core.hookPath: %S\n\n" + "Install Doom's commit-msg and pre-push git hooks anyway?") + hooks-path)) + (user-error "Aborted"))) + (make-directory hooks-path 'parents) + (print-group! + (dolist (hook '("commit-msg" "pre-push")) + (let* ((hook (doom-path hooks-path hook)) + (overwrite-p (file-exists-p hook))) + (with-temp-file hook + (insert "#!/usr/bin/env sh\n" + (doom-path doom-emacs-dir "bin/doom") + " --no-color ci hook " (file-name-base hook) + " \"$@\"")) + (set-file-modes hook #o700) + (print! (success "%s %s") + (if overwrite-p "Overwrote" "Created") + (path hook))))))) + +(defcli! (ci lint-commits) (from &optional to) + "TODO" + (with-temp-buffer + (insert + (cdr (doom-call-process + "git" "log" + (format "%s...%s" from (or to (concat from "~1")))))) + (doom-ci--lint + (let (commits) + (while (re-search-backward "^commit \\([a-z0-9]\\{40\\}\\)" nil t) + (push (cons (match-string 1) + (replace-regexp-in-string + "^ " "" + (save-excursion + (buffer-substring-no-properties + (search-forward "\n\n") + (if (re-search-forward "\ncommit \\([a-z0-9]\\{40\\}\\)" nil t) + (match-beginning 0) + (point-max)))))) + commits)) + commits)))) + +;;; TODO +(defcli! (ci run-tests) (&rest targets) :stub t) + +;;; doom ci hook +(defcli! (ci hook commit-msg) (file) + "Run git commit-msg hook. + +Lints the current commit message." (with-temp-buffer (insert-file-contents file) - (doom-cli--ci--lint - (list (cons - "CURRENT" - (buffer-substring (point-min) - (if (re-search-forward "^# Please enter the commit message" nil t) - (match-beginning 0) - (point-max)))))))) + (doom-ci--lint + `(("CURRENT" . + ,(buffer-substring + (point-min) + (if (re-search-forward "^# Please enter the commit message" nil t) + (match-beginning 0) + (point-max)))))))) -(defun doom-cli--ci-hook-pre-push (_remote _url) +(defcli! (ci hook pre-push) (remote url) + "Run git pre-push hook. + +Prevents pushing if there are unrebased or WIP commits." (with-temp-buffer (let ((z40 (make-string 40 ?0)) line error) @@ -318,6 +341,7 @@ Note: warnings are not considered failures.") (catch 'continue (seq-let (local-ref local-sha remote-ref remote-sha) (split-string line " ") + ;; TODO Extract this branch detection to a variable (unless (or (string-match-p "^refs/heads/\\(master\\|main\\)$" remote-ref) (equal local-sha z40)) (throw 'continue t)) @@ -325,7 +349,7 @@ Note: warnings are not considered failures.") (mapc (lambda (commit) (seq-let (hash msg) (split-string commit "\t") (setq error t) - (print! (info "%S commit in %s" + (print! (item "%S commit in %s" (car (split-string msg " ")) (substring hash 0 12))))) (split-string @@ -339,13 +363,20 @@ Note: warnings are not considered failures.") "\n" t)) (when error (print! (error "Aborting push due to unrebased WIP, squash!, or fixup! commits")) - (throw 'exit 1))))))))) + (exit! 1))))))))) ;; -;;; +;;; Helpers -(defun doom-cli--parse-commit (commit-msg) +(cl-defun doom-ci-enforce-scopeless-types (scope (&key type scopes summary &allow-other-keys)) + "Complain about scoped commit types that shouldn't be scoped." + (when (memq type doom-ci-commit-scopeless-types) + (user-error "Scopes for %s commits should go after the colon, not before" + type))) + + +(defun doom-ci--parse-commit (commit-msg) (with-temp-buffer (save-excursion (insert commit-msg)) (append @@ -379,7 +410,7 @@ Note: warnings are not considered failures.") (match-string 2))))) `(:bumps ,(cl-sort (delete-dups bumps) #'string-lessp :key #'car))))))) -(defun doom-cli--parse-bumps (from end) +(defun doom-ci--parse-bumps (from end) (with-temp-buffer (save-excursion (insert @@ -397,13 +428,13 @@ Note: warnings are not considered failures.") (match-string 2))))) (cl-sort (delete-dups packages) #'string-lessp :key #'car))))) -(defun doom-cli--ci--lint (commits) +(defun doom-ci--lint (commits) (let ((warnings 0) (failures 0)) (print! (start "Linting %d commits" (length commits))) (print-group! (pcase-dolist (`(,ref . ,commitmsg) commits) - (let* ((commit (doom-cli--parse-commit commitmsg)) + (let* ((commit (doom-ci--parse-commit commitmsg)) (shortref (substring ref 0 7)) (subject (plist-get commit :subject))) (cl-block 'linter @@ -419,7 +450,7 @@ Note: warnings are not considered failures.") (print! (start "%s %s") shortref subject) (print-group! (mapc (doom-rpartial #'apply commit) - doom-cli-commit-rules))))))) + doom-ci-commit-rules))))))) (let ((issues (+ warnings failures))) (if (= issues 0) (print! (success "There were no issues!")) @@ -427,26 +458,8 @@ Note: warnings are not considered failures.") (if (> failures 0) (print! (warn "Failures: %d" failures))) (print! "\nSee https://discourse.doomemacs.org/git-conventions") (unless (zerop failures) - (throw 'exit 1))) + (exit! 1))) t))) -(defun doom-cli--ci-lint-commits (from &optional to) - (with-temp-buffer - (insert - (cdr (doom-call-process - "git" "log" - (format "%s...%s" from (or to (concat from "~1")))))) - (doom-cli--ci--lint - (let (commits) - (while (re-search-backward "^commit \\([a-z0-9]\\{40\\}\\)" nil t) - (push (cons (match-string 1) - (replace-regexp-in-string - "^ " "" - (save-excursion - (buffer-substring-no-properties - (search-forward "\n\n") - (if (re-search-forward "\ncommit \\([a-z0-9]\\{40\\}\\)" nil t) - (match-beginning 0) - (point-max)))))) - commits)) - commits)))) +(provide 'core-cli-ci) +;;; ci.el ends here diff --git a/core/cli/byte-compile.el b/core/cli/compile.el similarity index 87% rename from core/cli/byte-compile.el rename to core/cli/compile.el index 6ed8084f8..ee5c4b5bc 100644 --- a/core/cli/byte-compile.el +++ b/core/cli/compile.el @@ -1,10 +1,19 @@ -;;; core/cli/byte-compile.el -*- lexical-binding: t; -*- +;;; core/cli/commands/byte-compile.el -*- lexical-binding: t; -*- -(defcli! (compile c) - ((recompile-p ["-r" "--recompile"]) - (core-p ["-c" "--core"]) - (private-p ["-p" "--private"]) - (verbose-p ["-v" "--verbose"])) +;; +;;; Variables + +;; None yet! + + +;; +;;; Commands + +(defcli! ((compile c)) + ((recompile-p ("-r" "--recompile")) + (core-p ("-c" "--core")) + (private-p ("-p" "--private")) + (verbose-p ("-v" "--verbose"))) "Byte-compiles your config or selected modules. compile [TARGETS...] @@ -14,7 +23,7 @@ Accepts :core and :private as special arguments, which target Doom's core files and your private config files, respectively. To recompile your packages, use 'doom build' instead." - (doom-cli-byte-compile + (doom-cli-compile (if (or core-p private-p) (append (if core-p (doom-glob doom-emacs-dir "init.el")) (if core-p (list doom-core-dir)) @@ -38,23 +47,13 @@ and your private config files, respectively. To recompile your packages, use (defcli! clean () "Delete all *.elc files." - :bare t - (doom-clean-byte-compiled-files)) + (doom-compile-clean)) ;; -;; Helpers +;;; Helpers -(defun doom--byte-compile-ignore-file-p (path) - (let ((filename (file-name-nondirectory path))) - (or (not (equal (file-name-extension path) "el")) - (member filename (list "packages.el" "doctor.el")) - (string-prefix-p "." filename) - (string-prefix-p "test-" filename) - (string-prefix-p "flycheck_" filename) - (string-suffix-p ".example.el" filename)))) - -(cl-defun doom-cli-byte-compile (&optional targets recompile-p verbose-p) +(cl-defun doom-cli-compile (&optional targets recompile-p verbose-p) "Byte compiles your emacs configuration. init.el is always byte-compiled by this. @@ -69,7 +68,7 @@ WARNING: byte-compilation yields marginal gains and makes debugging new issues difficult. It is recommended you don't use it unless you understand the reprecussions. -Use `doom-clean-byte-compiled-files' or `make clean' to reverse +Use `doom-compile-clean' or `make clean' to reverse byte-compilation. If RECOMPILE-P is non-nil, only recompile out-of-date files." @@ -85,11 +84,11 @@ If RECOMPILE-P is non-nil, only recompile out-of-date files." ;; Assemble el files we want to compile, and preserve in the order ;; they are loaded in, so we don't run into any scary catch-22s ;; while byte-compiling, like missing macros. - (cons (let ((target-dirs (cl-remove-if-not #'file-directory-p targets))) + (cons (let ((target-dirs (seq-filter #'file-directory-p targets))) (lambda (path) - (and (not (doom--byte-compile-ignore-file-p path)) - (cl-find-if (doom-partial #'file-in-directory-p path) - target-dirs) + (and (not (doom-compile--ignore-file-p path)) + (seq-find (doom-partial #'file-in-directory-p path) + target-dirs) (cl-pushnew path targets)))) after-load-functions)))) (doom-log "Reloading Doom in preparation for byte-compilation") @@ -103,7 +102,7 @@ If RECOMPILE-P is non-nil, only recompile out-of-date files." (quiet! (doom-initialize-modules)))) (if (null targets) - (print! (info "No targets to %scompile" (if recompile-p "re" ""))) + (print! (item "No targets to %scompile" (if recompile-p "re" ""))) (print! (start "%scompiling your config...") (if recompile-p "Re" "Byte-")) @@ -112,7 +111,7 @@ If RECOMPILE-P is non-nil, only recompile out-of-date files." (setq targets (cl-remove-if #'file-directory-p targets))) (prependq! targets (doom-files-in - dir :match "\\.el" :filter #'doom--byte-compile-ignore-file-p))) + dir :match "\\.el" :filter #'doom-compile--ignore-file-p))) (print-group! (require 'use-package) @@ -164,8 +163,7 @@ If RECOMPILE-P is non-nil, only recompile out-of-date files." (byte-compile-file target) (quiet! (byte-compile-file target)))) (`no-byte-compile - (print! (debug "(% 3d/%d) Ignored %s") - i total-modules (relpath target)) + (doom-log "(% 3d/%d) Ignored %s" i total-modules (relpath target)) total-noop) (`nil (print! (error "(% 3d/%d) Failed to compile %s") @@ -183,7 +181,16 @@ If RECOMPILE-P is non-nil, only recompile out-of-date files." "Reverting changes...") (signal 'doom-error (list 'byte-compile e)))))))) -(defun doom-clean-byte-compiled-files () +(defun doom-compile--ignore-file-p (path) + (let ((filename (file-name-nondirectory path))) + (or (not (equal (file-name-extension path) "el")) + (member filename (list "packages.el" "doctor.el")) + (string-prefix-p "." filename) + (string-prefix-p "test-" filename) + (string-prefix-p "flycheck_" filename) + (string-suffix-p ".example.el" filename)))) + +(defun doom-compile-clean () "Delete all the compiled elc files in your Emacs configuration and private module. This does not include your byte-compiled, third party packages.'" (require 'core-modules) @@ -204,5 +211,8 @@ module. This does not include your byte-compiled, third party packages.'" finally do (print! (if (> success 0) (success "\033[K%d elc files deleted" success) - (info "\033[KNo elc files to clean")))) + (item "\033[KNo elc files to clean")))) t)) + +(provide 'core-cli-compile) +;;; compile.el ends here diff --git a/core/cli/debug.el b/core/cli/debug.el deleted file mode 100644 index 20502f68d..000000000 --- a/core/cli/debug.el +++ /dev/null @@ -1,86 +0,0 @@ -;;; core/cli/debug.el -*- lexical-binding: t; -*- - -(load! "autoload/debug" doom-core-dir) - -;; -;;; Commands - -(defcli! info - ((format ["--json" "--md" "--lisp"] "What format to dump info into")) - "Output system info in markdown for bug reports." - (with-temp-buffer - (pcase format - ("--json" - (require 'json) - (insert (json-encode (doom-info))) - (json-pretty-print-buffer)) - ("--lisp" - (pp (doom-info))) - (`nil - (dolist (spec (cl-remove-if-not #'cdr (doom-info))) - (insert! "%-11s %s\n" - ((car spec) - (if (listp (cdr spec)) - (mapconcat (lambda (x) (format "%s" x)) - (cdr spec) " ") - (cdr spec)))))) - (_ - (user-error "I don't understand %S. Did you mean --json, --md/--markdown or --lisp?" - format))) - (print! (buffer-string))) - nil) - -(defcli! (version v) () - "Show version information for Doom & Emacs." - (doom/version) - nil) - -(defcli! amisecure () - "TODO" - (unless (string-match-p "\\_" system-configuration-features) - (warn "gnutls support isn't built into Emacs, there may be problems")) - (if-let* ((bad-hosts - (cl-loop for bad - in '("https://expired.badssl.com/" - "https://wrong.host.badssl.com/" - "https://self-signed.badssl.com/" - "https://untrusted-root.badssl.com/" - ;; "https://revoked.badssl.com/" - ;; "https://pinning-test.badssl.com/" - "https://sha1-intermediate.badssl.com/" - "https://rc4-md5.badssl.com/" - "https://rc4.badssl.com/" - "https://3des.badssl.com/" - "https://null.badssl.com/" - "https://sha1-intermediate.badssl.com/" - ;; "https://client-cert-missing.badssl.com/" - "https://dh480.badssl.com/" - "https://dh512.badssl.com/" - "https://dh-small-subgroup.badssl.com/" - "https://dh-composite.badssl.com/" - "https://invalid-expected-sct.badssl.com/" - ;; "https://no-sct.badssl.com/" - ;; "https://mixed-script.badssl.com/" - ;; "https://very.badssl.com/" - "https://subdomain.preloaded-hsts.badssl.com/" - "https://superfish.badssl.com/" - "https://edellroot.badssl.com/" - "https://dsdtestprovider.badssl.com/" - "https://preact-cli.badssl.com/" - "https://webpack-dev-server.badssl.com/" - "https://captive-portal.badssl.com/" - "https://mitm-software.badssl.com/" - "https://sha1-2016.badssl.com/" - "https://sha1-2017.badssl.com/") - if (condition-case _e - (url-retrieve-synchronously bad) - (error nil)) - collect bad))) - (print! (error "tls seems to be misconfigured (it got %s).") - bad-hosts) - (url-retrieve "https://badssl.com" - (lambda (status) - (if (or (not status) (plist-member status :error)) - (print! (warn "Something went wrong.\n\n%s") (pp-to-string status)) - (print! (success "Your trust roots are set up properly.\n\n%s") (pp-to-string status)) - t))))) diff --git a/core/cli/doctor.el b/core/cli/doctor.el index fa5d556d8..854851530 100644 --- a/core/cli/doctor.el +++ b/core/cli/doctor.el @@ -1,9 +1,14 @@ -;;; core/cli/doctor.el -*- lexical-binding: t; -*- +;;; core/cli/doctor.el --- userland heuristics and Emacs diagnostics -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: -(defvar doom-warnings ()) -(defvar doom-errors ()) +(defvar doom-doctor--warnings ()) +(defvar doom-doctor--errors ()) + + +;; +;;; DSL -;;; Helpers (defun elc-check-dir (dir) (dolist (file (directory-files-recursively dir "\\.elc$")) (when (file-newer-than-file-p (concat (file-name-sans-extension file) ".el") @@ -14,27 +19,28 @@ `(unless ,condition (error! ,message ,@args))) - -;;; Logging (defmacro error! (&rest args) `(progn (unless inhibit-message (print! (error ,@args))) - (push (format! (error ,@args)) doom-errors))) + (push (format! (error ,@args)) doom-doctor--errors))) + (defmacro warn! (&rest args) `(progn (unless inhibit-message (print! (warn ,@args))) - (push (format! (warn ,@args)) doom-warnings))) + (push (format! (warn ,@args)) doom-doctor--warnings))) + (defmacro success! (&rest args) `(print! (green ,@args))) + (defmacro section! (&rest args) `(print! (bold (blue ,@args)))) (defmacro explain! (&rest args) - `(print-group! (print! (autofill ,@args)))) + `(print-group! (print! (fill (string-join (list ,@args) "\n"))))) ;; ;;; CLI commands -(defcli! (doctor doc) () +(defcli! ((doctor doc)) () "Diagnoses common issues on your system. The Doom doctor is essentially one big, self-contained elisp shell script that @@ -43,7 +49,7 @@ Issues that could intefere with Doom Emacs. Doom modules may optionally have a doctor.el file to run their own heuristics in." - :bare t + :benchmark nil (print! "The doctor will see you now...\n") ;; REVIEW Refactor me @@ -55,10 +61,10 @@ in." ;; There are 2 newlines between each item to fight against ;; the (fill-region) call in `doom--output-autofill' (explain! "Doom supports this version, but you are using a development version of Emacs! " - "Be prepared for possibly weekly breakages that\n\n" - "\t- you will have to investigate yourself,\n\n" - "\t- might appear, or be solved, on any Emacs update,\n\n" - "\t- might depend subtly on upstream packages updates\n\n" + "Be prepared for possibly weekly breakages that\n" + "\t- you will have to investigate yourself." + "\t- might appear, or be solved, on any Emacs update." + "\t- might depend subtly on upstream packages updates.\n" "You might need to unpin packages to get a fix for a specific commit of Emacs, " "and you should be ready to downgrade Emacs if something is just not fixable.")) (EMACS29+ @@ -152,9 +158,11 @@ in." (print! (start "Checking Doom Emacs...")) (condition-case-unless-debug ex (print-group! - (let ((doom-interactive-p 'doctor)) - (doom-initialize 'force) - (doom-initialize-modules)) + (let ((doom-interactive-p 'doctor) + (noninteractive nil)) + (defvar doom-reloading-p nil) + (require 'core-start) + (doom-initialize-packages)) (print! (success "Initialized Doom Emacs %s") doom-version) (print! @@ -234,8 +242,8 @@ in." (maphash (lambda (key plist) (let (doom-local-errors doom-local-warnings) - (let (doom-errors - doom-warnings) + (let (doom-doctor--errors + doom-doctor--warnings) (condition-case-unless-debug ex (let ((doctor-file (doom-module-path (car key) (cdr key) "doctor.el")) (packages-file (doom-module-path (car key) (cdr key) "packages.el"))) @@ -247,21 +255,23 @@ in." unless (or (doom-package-get name :disable) (eval (doom-package-get name :ignore)) (plist-member (doom-package-get name :recipe) :local-repo) - (doom-package-built-in-p name) - (doom-package-installed-p name)) + (locate-library (symbol-name name)) + ;; (doom-package-built-in-p name) + ;; (doom-package-installed-p name) + ) do (print! (error "Missing emacs package: %S") name)) (let ((inhibit-message t)) (load doctor-file 'noerror 'nomessage))) (file-missing (error! "%s" (error-message-string ex))) (error (error! "Syntax error: %s" ex))) - (when (or doom-errors doom-warnings) + (when (or doom-doctor--errors doom-doctor--warnings) (print-group! (print! (start (bold "%s %s")) (car key) (cdr key)) - (print! "%s" (string-join (append doom-errors doom-warnings) "\n"))) - (setq doom-local-errors doom-errors - doom-local-warnings doom-warnings))) - (appendq! doom-errors doom-local-errors) - (appendq! doom-warnings doom-local-warnings))) + (print! "%s" (string-join (append doom-doctor--errors doom-doctor--warnings) "\n"))) + (setq doom-local-errors doom-doctor--errors + doom-local-warnings doom-doctor--warnings))) + (appendq! doom-doctor--errors doom-local-errors) + (appendq! doom-doctor--warnings doom-local-warnings))) doom-modules))) (error (warn! "Attempt to load DOOM failed\n %s\n" @@ -269,15 +279,18 @@ in." (setq doom-modules nil))) ;; Final report - (message "") - (dolist (msg (list (list doom-errors "error" 'red) - (list doom-warnings "warning" 'yellow))) + (terpri) + (dolist (msg (list (list doom-doctor--warnings "warning" 'yellow) + (list doom-doctor--errors "error" 'red))) (when (car msg) (print! (color (nth 2 msg) (if (cdr msg) "There are %d %ss!" "There is %d %s!") (length (car msg)) (nth 1 msg))))) - (unless (or doom-errors doom-warnings) + (unless (or doom-doctor--errors doom-doctor--warnings) (success! "Everything seems fine, happy Emacs'ing!")) - t) + (exit! :pager? "+G")) + +(provide 'core-cli-doctor) +;;; doctor.el ends here diff --git a/core/cli/env.el b/core/cli/env.el index c1e8991b1..f2bcc5b71 100644 --- a/core/cli/env.el +++ b/core/cli/env.el @@ -1,17 +1,54 @@ -;;; core/cli/env.el -*- lexical-binding: t; -*- +;;; core/cli/env.el --- envvar file generator -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: + +;; +;;; Variables + +(defvar doom-env-file (doom-path doom-profile-data-dir "env") + "The location of your envvar file, generated by `doom env`. + +This file contains environment variables scraped from your shell environment, +which is loaded at startup (if it exists). This is helpful if Emacs can't +\(easily) be launched from the correct shell session (particularly for MacOS +users).") + +(defvar doom-env-deny + '(;; Unix/shell state that shouldn't be persisted + "^HOME$" "^\\(OLD\\)?PWD$" "^SHLVL$" "^PS1$" "^R?PROMPT$" "^TERM\\(CAP\\)?$" + "^USER$" "^GIT_CONFIG" "^INSIDE_EMACS$" + ;; X server or services' variables that shouldn't be persisted + "^DISPLAY$" "^DBUS_SESSION_BUS_ADDRESS$" "^XAUTHORITY$" "^XDG_SESSION_TYPE$" + ;; Windows+WSL envvars that shouldn't be persisted + "^WSL_INTEROP$" + ;; ssh and gpg variables (likely to become stale) + "^SSH_\\(AUTH_SOCK\\|AGENT_PID\\)$" "^\\(SSH\\|GPG\\)_TTY$" + "^GPG_AGENT_INFO$" + ;; Internal Doom envvars + "^DEBUG$" "^INSECURE$" "^\\(EMACS\\|DOOM\\)DIR$" "^__") + "Environment variables to omit from envvar files. + +Each string is a regexp, matched against variable names to omit from +`doom-env-file'.") + +(defvar doom-env-allow '() + "Environment variables to include in envvar files. + +This overrules `doom-env-deny'. Each string is a regexp, matched against +variable names to omit from `doom-env-file'.") + + +;; +;;; Commands (defcli! env - ((allow ["-a" "--allow" regexp] "An additive envvar whitelist regexp") - (reject ["-r" "--reject" regexp] "An additive envvar blacklist regexp") - (allow-only ["-A" regexp] "Blacklist everything but REGEXP") - (reject-only ["-R" regexp] "Whitelist everything but REGEXP") - (clear-p ["-c" "--clear"] "Clear and delete your envvar file") - (outputfile ["-o" path] - "Generate the envvar file at PATH. Envvar files that aren't in -`doom-env-file' won't be loaded automatically at startup. You will need to load -them manually from your private config with the `doom-load-envvars-file' -function.")) - "Creates or regenerates your envvars file. + ((allow-only ("--allow-all")) + (deny-only ("--deny-all")) + (output-file ("-o" path) "Write envvar file to non-standard PATH.") + ;; TODO (refresh? ("-r" "--refresh")) + &multiple + (rules ("-a" "--allow" "-d" "--deny" regexp) "Allow/deny envvars that match REGEXP")) + "(Re)generates envvars file from your shell environment. The envvars file is created by scraping the current shell environment into newline-delimited KEY=VALUE pairs. Typically by running '$SHELL -ic env' (or @@ -41,101 +78,65 @@ Why this over exec-path-from-shell? I'd rather it inherit your shell environment /correctly/ (and /completely/) or not at all. It frontloads the debugging process rather than hiding it until you least want to deal with it." - (let ((env-file (expand-file-name (or outputfile doom-env-file)))) - (if (null clear-p) - (doom-cli-reload-env-file - 'force env-file - (append (if reject-only (list ".")) (list allow allow-only)) - (append (if allow-only (list ".")) (list reject reject-only))) - (unless (file-exists-p env-file) - (user-error! "%S does not exist to be cleared" (path env-file))) - (delete-file env-file) - (print! (success "Successfully deleted %S") (path env-file))))) + (let ((env-file (doom-path (or output-file doom-env-file)))) + (with-temp-file env-file + (setq-local coding-system-for-write 'utf-8-unix) + (print! (start "%s envvars file") + (if (file-exists-p env-file) + "Regenerating" + "Generating")) + (print-group! + (when doom-interactive-p + (user-error "doom env: must be run on the command line, not an interactive session")) + (goto-char (point-min)) + (insert + ";; -*- mode: lisp-interaction; coding: utf-8-unix; -*-\n" + ";; ---------------------------------------------------------------------------\n" + ";; This file was auto-generated by `doom env'. It contains a list of environment\n" + ";; variables scraped from your default shell (based on your settings for \n" + ";; `doom-env-allow' and `doom-env-deny').\n" + ";;\n" + (if (file-equal-p env-file doom-env-file) + (concat ";; It is NOT safe to edit this file. Changes will be overwritten next time you\n" + ";; run 'doom sync'. To create a safe-to-edit envvar file use:\n;;\n" + ";; doom env -o ~/.doom.d/myenv\n;;\n" + ";; And load it with (doom-load-envvars-file \"~/.doom.d/myenv\").\n") + (concat ";; This file is safe to edit by hand, but needs to be loaded manually with:\n;;\n" + ";; (doom-load-envvars-file \"path/to/this/file\")\n;;\n" + ";; Use 'doom env -o path/to/this/file' to regenerate it.")) + "\n") + ;; We assume that this noninteractive session was spawned from the user's + ;; interactive shell, so simply dump `process-environment' to a file. + ;; + ;; This should be well-formatted, in case humans want to hand-modify it. + (let* ((denylist (remq nil (append (if deny-only '(".")) (list allow-only) doom-env-deny))) + (allowlist (remq nil (append (if allow-only '(".")) (list deny-only) doom-env-allow)))) + (dolist (rule rules) + (push (cdr rule) (if (member (car rule) '("-a" "--allow")) + allowlist + denylist))) + (insert "(") + (dolist (env (get 'process-environment 'initial-value)) + (catch 'skip + (let* ((var (car (split-string env "="))) + (pred (doom-rpartial #'string-match-p var))) + (when (seq-find pred denylist) + (if (seq-find pred allowlist) + (doom-log "Whitelisted %s" var) + (doom-log "Ignored %s" var) + (throw 'skip t))) + (insert (prin1-to-string env) "\n ")))) + (insert ")")) + (print! (success "Generated %s") (path env-file)) + t)))) +(defcli! (env (clear c)) () + "Deletes the default envvar file." + (let ((env-file (abbreviate-file-name doom-env-file))) + (unless (file-exists-p env-file) + (user-error "No envvar file to delete: %s" env-file)) + (delete-file env-file) + (print! (success "Deleted %s") (path env-file)))) -;; -;; Helpers - -(defvar doom-env-blacklist - '(;; State that may be problematic if overwritten - "^HOME$" "^\\(OLD\\)?PWD$" "^SHLVL$" "^PS1$" "^R?PROMPT$" "^TERM\\(CAP\\)?$" - "^USER$" "^GIT_CONFIG" - ;; X server or services' variables that shouldn't be persisted - "^DISPLAY$" "^DBUS_SESSION_BUS_ADDRESS$" "^XAUTHORITY$" "^XDG_SESSION_TYPE$" - ;; Windows+WSL envvars that shouldn't be persisted - "^WSL_INTEROP$" - ;; ssh and gpg variables (likely to become stale) - "^SSH_\\(AUTH_SOCK\\|AGENT_PID\\)$" "^\\(SSH\\|GPG\\)_TTY$" - "^GPG_AGENT_INFO$" - ;; Internal Doom envvars - "^DEBUG$" "^INSECURE$" "^YES$" "^__") - "Environment variables to not save in `doom-env-file'. - -Each string is a regexp, matched against variable names to omit from -`doom-env-file'.") - -(defvar doom-env-whitelist '() - "A whitelist for envvars to save in `doom-env-file'. - -This overrules `doom-env-ignored-vars'. Each string is a regexp, matched against -variable names to omit from `doom-env-file'.") - -(defun doom-cli-reload-env-file (&optional force-p env-file whitelist blacklist) - "Generates `doom-env-file', if it doesn't exist (or if FORCE-P). - -This scrapes the variables from your shell environment by running -`doom-env-executable' through `shell-file-name' with `doom-env-switches'. By -default, on Linux, this is '$SHELL -ic /usr/bin/env'. Variables in -`doom-env-ignored-vars' are removed." - (let ((env-file (expand-file-name (or env-file doom-env-file)))) - (when (or force-p (not (file-exists-p env-file))) - (with-temp-file env-file - (setq-local coding-system-for-write 'utf-8-unix) - (print! (start "%s envvars file at %S") - (if (file-exists-p env-file) - "Regenerating" - "Generating") - (path env-file)) - (print-group! - (when doom-interactive-p - (user-error "'doom env' must be run on the command line, not an interactive session")) - (goto-char (point-min)) - (insert - (concat - ";; -*- mode: lisp-interaction; coding: utf-8-unix; -*-\n" - ";; ---------------------------------------------------------------------------\n" - ";; This file was auto-generated by `doom env'. It contains a list of environment\n" - ";; variables scraped from your default shell (excluding variables blacklisted\n" - ";; in doom-env-ignored-vars).\n" - ";;\n" - (if (file-equal-p env-file doom-env-file) - (concat ";; It is NOT safe to edit this file. Changes will be overwritten next time you\n" - ";; run 'doom sync'. To create a safe-to-edit envvar file use:\n;;\n" - ";; doom env -o ~/.doom.d/myenv\n;;\n" - ";; And load it with (doom-load-envvars-file \"~/.doom.d/myenv\").\n") - (concat ";; This file is safe to edit by hand, but needs to be loaded manually with:\n;;\n" - ";; (doom-load-envvars-file \"path/to/this/file\")\n;;\n" - ";; Use 'doom env -o path/to/this/file' to regenerate it.")) - "\n")) - ;; We assume that this noninteractive session was spawned from the - ;; user's interactive shell, therefore simply dump - ;; `process-environment' to a file. - ;; - ;; This file should be somewhat formatted, so humans could hand-modify - ;; it if they please. - (let ((blacklist (remq nil (append blacklist doom-env-blacklist))) - (whitelist (remq nil (append whitelist doom-env-whitelist)))) - (insert "(") - (dolist (env (get 'process-environment 'initial-value)) - (catch 'skip - (let* ((var (car (split-string env "="))) - (pred (doom-rpartial #'string-match-p var))) - (when (seq-find pred blacklist) - (if (seq-find pred whitelist) - (doom-log "Whitelisted %s" var) - (doom-log "Ignored %s" var) - (throw 'skip t))) - (insert (prin1-to-string env) "\n ")))) - (insert ")")) - (print! (success "Successfully generated %S") (path env-file)) - t))))) +(provide 'core-cli-env) +;;; env.el ends here diff --git a/core/cli/help.el b/core/cli/help.el index 11bc2e77f..19f39f059 100644 --- a/core/cli/help.el +++ b/core/cli/help.el @@ -1,102 +1,458 @@ -;;; core/cli/help.el -*- lexical-binding: t; -*- +;;; ../../projects/dotfiles/emacs/core/cli/help.el -*- lexical-binding: t; -*- +;;; Commentary: +;; +;; This file defines special commands that the Doom CLI will invoke when a +;; command is passed with -?, --help, or --version. They can also be aliased to +;; a sub-command to make more of its capabilities accessible to users, with: +;; +;; (defalias! (myscript (help h)) (:help)) +;; +;; You can define your own command-specific help handlers, e.g. +;; +;; (defcli! (:help myscript subcommand) () ...) +;; +;; And it will be invoked instead of the generic one. +;; +;;; Code: -(defun doom--cli-print-signature (cli) - (print! (bold "Usage: doom %s%s%s") - (if (doom-cli-internal-p cli) - "" - (concat (doom-cli-name cli) " ")) - (if-let* ((optlist (doom-cli-optlist cli)) - (flags (cl-loop for opt in optlist - append (doom-cli-option-flags opt))) - (fn (doom-partial #'string-prefix-p "--"))) - (concat (when-let (short-flags (cl-remove-if fn flags)) - ;; TODO Show arguments of short flags - (format "[-%s]" - (string-join (mapcar (doom-rpartial #'substring 1 nil) short-flags) - ""))) - ;; TODO Show long flags - ;; (when-let (long-flags (cl-remove-if-not fn flags)) - ;; (concat " " (string-join long-flags " "))) - " ") - "") - (if-let (arglist (doom-cli-arglist cli)) - (string-join (append (cl-loop for arg in arglist - until (memq arg cl--lambda-list-keywords) - collect (upcase (symbol-name arg))) - (cl-loop for arg in (cdr (memq '&optional arglist)) - until (memq arg cl--lambda-list-keywords) - collect (format "[%s]" (upcase (symbol-name arg))))) - " ") - "")) - (when-let (aliases (doom-cli-aliases cli)) - (print! "Aliases: %s" (string-join aliases ", ")))) +;; +;;; Variables -(defun doom--cli-print-desc (cli &optional short) - (print! "%s" - (if short - (car (split-string (doom-cli-desc cli) "\n")) - (doom-cli-desc cli)))) +(defvar doom-help-commands '("%p %c {-?,--help}") + "A list of help commands recognized for the running script. -(defun doom--cli-print-short-desc (cli) - (doom--cli-print-desc cli 'short)) - -(defun doom--cli-print-options (cli) - (when-let (optlist (doom-cli-optlist cli)) - (print! (bold "Options:")) - (print-group! - (cl-loop for opt in optlist - for desc = (doom-cli-option-desc opt) - for args = (doom-cli-option-args opt) - for flagstr = (string-join (doom-cli-option-flags opt) ", ") - do - ;; TODO Adjust columns dynamically - (print! "%-18s" - (concat flagstr - (when-let (arg (car args)) - (concat " " (upcase (symbol-name arg)))))) - (print-group! - (print! (autofill "%s") desc)))))) - - -(defun doom--cli-print (cli) - (doom--cli-print-signature cli) - (terpri) - (doom--cli-print-desc cli) - (terpri) - (doom--cli-print-options cli)) +Recognizes %p (for the prefix) and %c (for the active command).") ;; ;;; Commands -(defcli! (help h) (&optional command) - "Describe a command or list them all." - :bare t - (if command - (doom--cli-print (doom-cli-get (intern command))) - (doom--cli-print (doom-cli-get :doom)) +(defcli! (:root :help) + ((localonly? ("-g" "--no-global") "Hide global options") + (manpage? ("--manpage") "Generate in manpage format") + (commands? ("--commands") "List all known commands") + &multiple + (sections ("--synopsis" "--subcommands" "--similar" "--envvars" + "--postamble") + "Show only the specified sections.") + &context context + &args command) + "Show documentation for a Doom CLI command. + +OPTIONS: + --synopsis, --subcommands, --similar, --envvars, --postamble + TODO" + (doom-cli-load-all) + (when (doom-cli-context-error context) + (terpri)) + (let* ((command (cons (doom-cli-context-prefix context) command)) + (cli (doom-cli-get command t)) + (rcli (doom-cli-get cli)) + (fallbackcli (cl-loop with targets = (doom-cli--command-expand (butlast command) t) + for cmd in (cons command (nreverse targets)) + if (doom-cli-get cmd t) + return it))) + (cond (commands? + (let ((cli (or cli (doom-cli-get (doom-cli-context-prefix context))))) + (print! "Commands under '%s':\n%s" + (doom-cli-command-string cli) + (indent (doom-cli-help--render-commands + (or (doom-cli-subcommands cli) + (user-error "No commands found")) + :prefix (doom-cli-command cli) + :inline? t + :docs? t))))) + ((null sections) + (if (null cli) + (signal 'doom-cli-command-not-found-error command) + (doom-cli-help--print cli context manpage? (not localonly?)) + (exit! :pager?))) + (t + (dolist (section sections) + (unless (equal section (car sections)) (terpri)) + (pcase section + ("--synopsis" + (print! "%s" (doom-cli-help--render-synopsis + (doom-cli-help--synopsis cli) + "Usage: "))) + ("--subcommands" + (print! "%s\n%s" (bold "Available commands:") + (indent (doom-cli-help--render-commands + (doom-cli-subcommands rcli 1) + :prefix command + :grouped? t + :docs? t) + doom-print-indent-increment))) + ("--similar" + (unless command + (user-error "No command specified")) + (when-let (similar (doom-cli-help-similar-commands command 0.4)) + (print! "Similar commands:") + (dolist (command (seq-take similar 10)) + (print! (indent (item "(%d%%) %s")) + (* (car command) 100) + (doom-cli-command-string (cdr command)))))) + ("--envvars" + (let* ((key "ENVIRONMENT VARIABLES") + (clis (if command (doom-cli-find command) (hash-table-values doom-cli--table))) + (clis (seq-remove #'doom-cli-alias clis)) + (clis (seq-filter (fn!! (cdr (assoc key (doom-cli-docs %)))) clis)) + (clis (seq-group-by #'doom-cli-command clis))) + (print! "List of environment variables for %s:\n" command) + (if (null clis) + (print! (indent "None!")) + (dolist (group clis) + (print! (bold "%s%s:" + (doom-cli-command-string (car group)) + (if (doom-cli-fn (doom-cli-get (car group))) + "" " *"))) + (dolist (cli (cdr group)) + (print! (indent "%s") (markup (cdr (assoc key (doom-cli-docs cli)))))))))) + ("--postamble" + (print! "See %s for documentation." + (join (cl-loop with spec = + `((?p . ,(doom-cli-context-prefix context)) + (?c . ,(doom-cli-command-string (cdr (doom-cli-command cli))))) + for cmd in doom-help-commands + for formatted = (trim (format-spec cmd spec)) + collect (replace-regexp-in-string + " +" " " (format "'%s'" formatted))) + " or "))))))))) + +(defcli! (:root :version) ((simple? ("--simple")) &context context) + "Show installed versions of Doom, Doom modules, and Emacs." + (doom/version) + (unless simple? (terpri) - (print! (bold "Commands:")) - (print-group! - (dolist (group (seq-group-by (lambda (cli) - (plist-get (doom-cli-plist cli) :group)) - (cl-loop for name being the hash-keys of doom--cli-commands - for cli = (gethash name doom--cli-commands) - if (and (doom-cli-p cli) - (not (doom-cli-internal-p cli)) - (not (plist-get (doom-cli-plist cli) :hidden))) - collect cli))) - (if (null (car group)) - (dolist (cli (cdr group)) - (print! "%-16s %s" - (doom-cli-name cli) - (car (split-string (doom-cli-desc cli) "\n")))) - (print! "%-26s %s" - (bold (concat (car group) ":")) - (gethash (car group) doom--cli-groups)) - (print-group! - (dolist (cli (cdr group)) - (print! "%-16s %s" - (doom-cli-name cli) - (car (split-string (doom-cli-desc cli) "\n")))))) - (terpri))))) + (with-temp-buffer + (insert-file-contents (doom-path doom-emacs-dir "LICENSE")) + (re-search-forward "^Copyright (c) ") + (print! "%s\n" (trim (thing-at-point 'line t))) + (print! (p "Doom Emacs uses the MIT license and is provided without warranty " + "of any kind. You may redistribute and modify copies if " + "given proper attribution. See the LICENSE file for details."))))) + + +;; +;;; Helpers + +(defun doom-cli-help (cli) + "Return an alist of documentation summarizing CLI (a `doom-cli')." + (let ((docs (doom-cli-docs cli))) + `((command . ,(doom-cli-command-string cli)) + (summary . ,(or (cdr (assoc "SUMMARY" docs)) "TODO")) + (description . ,(or (cdr (assoc "MAIN" docs)) "TODO")) + (synopsis . ,(doom-cli-help--synopsis cli)) + (arguments . ,(doom-cli-help--arguments cli)) + (options . ,(doom-cli-help--options cli)) + (commands . ,(doom-cli-subcommands cli 1)) + (sections . ,(seq-filter #'cdr (cddr docs)))))) + +(defun doom-cli-help-similar-commands (command &optional maxscore) + "Return N commands that are similar to COMMAND." + (seq-take-while + (fn!! (>= (car %) (or maxscore 0.0))) + (seq-sort-by + #'car #'> + (cl-loop with prefix = (seq-find #'doom-cli-get (nreverse (doom-cli--command-expand command t))) + with input = (doom-cli-command-string (cdr (doom-cli--command command t))) + for command in (hash-table-keys doom-cli--table) + if (doom-cli-fn (doom-cli-get command)) + if (equal prefix (seq-take command (length prefix))) + collect (cons (doom-cli-help--similarity + input (doom-cli-command-string (cdr command))) + command))))) + +(defun doom-cli-help--similarity (s1 s2) + ;; Ratcliff-Obershelp similarity + (let* ((s1 (downcase s1)) + (s2 (downcase s2)) + (s1len (length s1)) + (s2len (length s2))) + (/ (if (or (zerop s1len) + (zerop s2len)) + 0.0 + (let ((i 0) (j 0) (score 0) jlast) + (while (< i s1len) + (unless jlast (setq jlast j)) + (if (and (< j s2len) + (= (aref s1 i) (aref s2 j))) + (progn (cl-incf score) + (cl-incf i) + (cl-incf j)) + (setq m 0) + (cl-incf j) + (when (>= j s2len) + (setq j (or jlast j) + jlast nil) + (cl-incf i)))) + (* 2.0 score))) + (+ (length s1) + (length s2))))) + +;;; Help: printers +;; TODO Parameterize optional args with `cl-defun' +(defun doom-cli-help--print (cli context &optional manpage? noglobal?) + "Write CLI's documentation in a manpage-esque format to stdout." + (let-alist (doom-cli-help cli) + (let* ((alist + `(,@(if manpage? + `((nil . ,(let* ((title (cadr (member "--load" command-line-args))) + (width (floor (/ (- (doom-cli-context-width context) + (length title)) + 2.0)))) + ;; FIXME Who am I fooling? + (format (format "%%-%ds%%s%%%ds" width width) + "DOOM(1)" title "DOOM(1)"))) + ("NAME" . ,(concat (doom-cli-command-string cli) " - " .summary)) + ("SYNOPSIS" . ,(doom-cli-help--render-synopsis .synopsis nil t)) + ("DESCRIPTION" . ,.description)) + `((nil . ,(doom-cli-help--render-synopsis .synopsis "Usage: ")) + (nil . ,(string-join (seq-remove #'string-empty-p (list .summary .description)) + "\n\n")))) + ("ARGUMENTS" . ,(doom-cli-help--render-arguments .arguments)) + ("COMMANDS" + . ,(doom-cli-help--render-commands + .commands :prefix (doom-cli-command cli) :grouped? t :docs? t)) + ("OPTIONS" + . ,(doom-cli-help--render-options + (if (or (not (doom-cli-fn cli)) localonly?) + `(,(assq 'local .options)) + .options) + cli))))) + (letf! (defun printsection (section) + (print! "%s\n" (if section (markup section) (dark "TODO")))) + (pcase-dolist (`(,label . ,contents) alist) + (when (and contents (not (string-blank-p contents))) + (when label + (print! (bold "%s%s") label (if manpage? "" ":"))) + (print-group-if! label (printsection contents)))) + (pcase-dolist (`(,label . ,contents) .sections) + (when (and contents (not (assoc label alist))) + (print! (bold "%s:") label) + (print-group! (printsection contents)))))))) + +;;; Help: synopsis +(defun doom-cli-help--synopsis (cli &optional all-options?) + (let* ((opts (doom-cli-help--options cli)) + (opts (mapcar #'car (if all-options? (mapcan #'cdr opts) (alist-get 'local opts)))) + (opts (cl-loop for opt in opts + for args = (cdar opt) + for switches = (mapcar #'car opt) + for multi? = (member "..." args) + if args + collect (format (if multi? "[%s %s]..." "[%s %s]") + (string-join switches "|") + (string-join (remove "..." args) "|")) + else collect (format "[%s]" (string-join switches "|")))) + (args (doom-cli-arguments cli)) + ;; (partial? (null (doom-cli-fn cli))) + (subcommands? (doom-cli-subcommands cli 1 :predicate? t))) + `((command . ,(doom-cli-command cli)) + (options ,@opts) + (required ,@(mapcar (fn!! (upcase (format "`%s'" %))) (if subcommands? '(command) (alist-get '&required args)))) + (optional ,@(mapcar (fn!! (upcase (format "[`%s']" %)))(alist-get '&optional args))) + (rest ,@(mapcar (fn!! (upcase (format "[`%s'...]" %))) (if subcommands? '(args) (alist-get '&args args)))) + (examples ,@(doom-cli-help--parse-docs (doom-cli-find cli t) "SYNOPSIS"))))) + +(defun doom-cli-help--render-synopsis (synopsis &optional prefix with-examples?) + (let-alist synopsis + (let ((doom-print-indent 0) + (prefix (or prefix "")) + (command (doom-cli-command-string .command))) + (with-temp-buffer + (insert! ("%s\n\n" + (fill (concat prefix + (bold (format "%s " command)) + (markup + (join (append .options + (and .options + (or .required + .optional + .rest) + (list (dark "[--]"))) + .required + .optional + .rest)))) + 80 (1+ (length (concat prefix command)))))) + (dolist (example (if with-examples? .examples)) + (insert! ("%s\n%s\n" (markup (car example)) + (if (cdr example) + (format "%s\n" (indent (markup (cdr example)) + doom-print-indent-increment)))))) + (string-trim-right (buffer-string)))))) + +;;; Help: arguments +(defun doom-cli-help--arguments (cli &optional all?) + (doom-cli-help--parse-docs (doom-cli-find cli t) "ARGUMENTS")) + +(defun doom-cli-help--render-arguments (arguments) + (mapconcat (lambda (arg) + (format! "%-20s\n%s" + (underscore (car arg)) + (indent (if (equal (cdr arg) "TODO") + (dark (cdr arg)) + (cdr arg)) + doom-print-indent-increment))) + arguments + "\n")) + +;;; Help: commands +(cl-defun doom-cli-help--render-commands (commands &key prefix grouped? docs? (inline? t)) + (with-temp-buffer + (let* ((doom-print-indent 0) + (commands (seq-group-by (fn!! (if grouped? (doom-cli-prop (doom-cli-get % t) :group))) commands)) + (toplevel (assq nil commands)) + (rest (nreverse (remove toplevel commands))) + (drop (if prefix (length prefix) 0)) + (minwidth (apply #'max (cl-loop for cmd in (apply #'append (mapcar #'cdr commands)) + for cmd = (seq-drop cmd drop) + collect (length (doom-cli-command-string cmd))))) + (ellipsis (doom-print--style 'dark " […]")) + (ellipsislen (- (length ellipsis) (if (eq doom-print-backend 'ansi) 2 4)))) + (dolist (group (cons toplevel rest)) + (let ((label (if (car-safe group) (cdr commands)))) + (when label + (insert! ((bold "%s:") (car group)) "\n")) + (print-group-if! label + (dolist (command (cdr group)) + (let* ((cli (doom-cli-get command t)) + (rcli (doom-cli-get command)) + (summary (doom-cli-short-docs rcli)) + (subcommands? (doom-cli-subcommands cli 1 :predicate? t))) + (insert! ((format "%%-%ds%%s%%s" + (+ (- minwidth doom-print-indent) + doom-print-indent-increment + (if subcommands? ellipsislen 0))) + (concat (doom-cli-command-string (seq-drop command drop)) + (if subcommands? ellipsis)) + (if inline? " " "\n") + (indent (if (and (doom-cli-alias cli) + (not (doom-cli-type rcli))) + (dark "-> %s" (doom-cli-command-string cli)) + (when docs? + (if summary (markup summary) (dark "TODO")))))) + "\n"))) + (when (cdr rest) + (insert "\n"))))) + (string-trim-right (buffer-string))))) + +;;; Help: options +(defun doom-cli-help--options (cli &optional noformatting?) + "Return an alist summarizing CLI's options. + +The alist's CAR are lists of formatted switches plus their arguments, e.g. +'((\"`--foo'\" \"`BAR'\") ...). Their CDR is their formatted documentation." + (let* ((docs (doom-cli-help--parse-docs (doom-cli-find cli t) "OPTIONS")) + (docs (mapcar (fn!! (cons (split-string (car %) ", ") + (cdr %))) + docs)) + (strfmt (if noformatting? "%s" "`%s'")) + local-options + global-options + seen) + (dolist (neighbor (nreverse (doom-cli-find (doom-cli-command cli)))) + (dolist (option (doom-cli-options neighbor)) + (when-let* ((switches (cl-loop for sw in (doom-cli-option-switches option) + if (and (doom-cli-option-flag-p option) + (string-prefix-p "--" sw)) + collect (format "--[no-]%s" (substring sw 2)) + else collect sw)) + (switches (seq-difference switches seen))) + (dolist (switch switches) (push switch seen)) + (push (cons (cl-loop for switch in switches + if (doom-cli-option-arguments option) + collect (cons (format strfmt switch) + (append (doom-cli-help--parse-args it noformatting?) + (when (doom-cli-option-multiple-p option) + (list "...")))) + else collect (list (format strfmt switch))) + (string-join + (or (delq + nil (cons (when-let (docs (doom-cli-option-docs option)) + (concat docs ".")) + (cl-loop for (flags . docs) in docs + unless (equal (seq-difference flags switches) flags) + collect docs))) + '("TODO")) + "\n\n")) + (if (equal (doom-cli-command neighbor) + (doom-cli-command cli)) + local-options + global-options))))) + `((local . ,(nreverse local-options)) + (global . ,(nreverse global-options))))) + +(defun doom-cli-help--render-options (options &optional cli) + (let ((doom-print-indent 0) + (local (assq 'local options)) + (global (assq 'global options))) + (when (or (cdr local) (cdr global)) + (letf! (defun printopts (opts) + (pcase-dolist (`(,switches . ,docs) (cdr opts)) + (let (multiple?) + (insert! + ("%s%s\n%s" + (mapconcat + (fn!! + (when (member "..." (cdr %)) + (setq multiple? t)) + (string-trim-right + (format "%s %s" + (doom-print--cli-markup (car %)) + (doom-print--cli-markup + (string-join (remove "..." (cdr %)) "|"))))) + switches + ", ") + (if multiple? ", ..." "") + (indent (fill (markup docs)) doom-print-indent-increment)) + "\n\n")))) + (with-temp-buffer + (if (null (cdr local)) + (insert (if global "This command has no local options.\n" "") "\n") + (printopts local)) + (when (cdr global) + (insert! ((bold "Global options:\n"))) + (print-group! (printopts global))) + (string-trim-right (buffer-string))))))) + +;;; Help: internal +(defun doom-cli-help--parse-args (args &optional noformatting?) + (cl-loop for arg in args + if (listp arg) + collect (string-join (doom-cli-help--parse-args arg noformatting?) "|") + else if (symbolp arg) + collect (format (if noformatting? "%s" "`%s'") (upcase (symbol-name arg))) + else collect arg)) + +(defun doom-cli-help--parse-docs (cli-list section-name) + (cl-check-type section-name string) + (let (alist) + (dolist (cli cli-list (nreverse alist)) + (when-let (section (cdr (assoc section-name (doom-cli-docs cli)))) + (with-temp-buffer + (save-excursion (insert section)) + (let ((lead (current-indentation)) + (buffer (current-buffer))) + (while (not (eobp)) + (let ((heading (string-trim (buffer-substring (point-at-bol) (point-at-eol)))) + (beg (point-at-bol 2)) + end) + (forward-line 1) + (while (and (not (eobp)) + (/= (current-indentation) lead) + (forward-line 1))) + (setf (alist-get heading alist nil nil #'equal) + (string-join + (delq + nil (list (alist-get heading alist nil nil #'equal) + (let ((end (point))) + (with-temp-buffer + (insert-buffer-substring buffer beg end) + (goto-char (point-min)) + (indent-rigidly (point-min) (point-max) (- (current-indentation))) + (string-trim-right (buffer-string)))))) + "\n\n")))))))))) + +(provide 'core-cli-help) +;;; help.el ends here diff --git a/core/cli/info.el b/core/cli/info.el new file mode 100644 index 000000000..e0a222b8d --- /dev/null +++ b/core/cli/info.el @@ -0,0 +1,34 @@ +;;; core/cli/info.el --- information about your Doom install -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: + +;; +;;; Variables + +;; None yet! + + +;; +;;; Commands + +(defcli! info + ((format ("--lisp" "--json") "What format to dump info into") + &context context) + "Print detailed information about your config for bug reports." + (with-temp-buffer + (pcase format + ("--json" + (require 'json) + (insert (json-encode (doom-info))) + (json-pretty-print-buffer)) + ("--lisp" + (pp (doom-info))) + (_ + (insert (doom-info-string + (if (doom-cli-context-pipe-p context :out t) + 72 + (doom-cli-context-width context)))))) + (print! "%s" (string-trim-right (buffer-string))))) + +(provide 'core-cli-info) +;;; info.el ends here diff --git a/core/cli/install.el b/core/cli/install.el index 2eff9a51d..19f368a9c 100644 --- a/core/cli/install.el +++ b/core/cli/install.el @@ -1,32 +1,50 @@ -;;; core/cli/install.el -*- lexical-binding: t; -*- +;;; core/cli/install.el --- Doom Emacs install wizard -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: -(defcli! (install i) - ((noconfig-p ["--no-config"] "Don't create DOOMDIR or dummy files therein") - (noenv-p ["--no-env"] "Don't generate an envvars file (see 'doom help env')") - (noinstall-p ["--no-install"] "Don't auto-install packages") - (nofonts-p ["--no-fonts"] "Don't install (or prompt to install) all-the-icons fonts") - (nohooks-p ["--no-hooks"] "Don't deploy git hooks")) +(eval-when-compile (require 'core-cli)) ; appease byte-compiler-sama + + +;; +;;; Variables + +;; None yet! + + +;; +;;; Commands + +(defcli! ((install i)) + (&flags + (config? ("--config" :yes) "Create `$DOOMDIR' or dummy files therein?") + (envfile? ("--env" :yes) "(Re)generate an envvars file? (see `$ doom help env`)") + (install? ("--install" :yes) "Auto-install packages?") + (fonts? ("--fonts" :yes) "Install (or prompt to install) all-the-icons fonts?") + (hooks? ("--hooks" :yes) "Deploy Doom's git hooks to itself?") + &context context) "Installs and sets up Doom Emacs for the first time. This command does the following: - 1. Creates DOOMDIR at ~/.doom.d, - 2. Copies ~/.emacs.d/init.example.el to $DOOMDIR/init.el (if it doesn't exist), - 3. Creates dummy files for $DOOMDIR/{config,packages}.el, - 4. Prompts you to generate an envvar file (same as 'doom env'), - 5. Installs any dependencies of enabled modules (specified by $DOOMDIR/init.el), + 1. Creates `$DOOMDIR' at ~/.doom.d, + 2. Copies ~/.emacs.d/init.example.el to `$DOOMDIR'/init.el (if it doesn't exist), + 3. Creates dummy files for `$DOOMDIR'/{config,packages}.el, + 4. Prompts you to generate an envvar file (same as `$ doom env`), + 5. Installs any dependencies of enabled modules (specified by `$DOOMDIR'/init.el), 6. And prompts to install all-the-icons' fonts This command is idempotent and safe to reuse. -The location of DOOMDIR can be changed with the environment variable of the same -name. e.g. +Change `$DOOMDIR' with the `--doomdir' option, e.g. - DOOMDIR=~/.config/doom doom install" + ``` + $ doom --doomdir /other/doom/config install + ```" (print! (green "Installing Doom Emacs!\n")) - (let ((default-directory doom-emacs-dir)) + (let ((default-directory doom-emacs-dir) + (yes? (doom-cli-context-suppress-prompts-p context))) ;; Create `doom-private-dir' - (if noconfig-p + (if (eq config? :no) (print! (warn "Not copying private config template, as requested")) ;; Create DOOMDIR in ~/.config/doom if ~/.config/emacs exists. (when (and (not (file-directory-p doom-private-dir)) @@ -34,39 +52,41 @@ name. e.g. (let ((xdg-config-dir (or (getenv "XDG_CONFIG_HOME") "~/.config"))) (when (file-in-directory-p doom-emacs-dir xdg-config-dir) (setq doom-private-dir (expand-file-name "doom/" xdg-config-dir))))) - (print! (start "Creating %s") (relpath doom-private-dir)) - (make-directory doom-private-dir 'parents) - (print-group! - (print! (success "Created %s") (relpath doom-private-dir))) + + (if (file-directory-p doom-private-dir) + (print! (item "Skipping %s (already exists)") (relpath doom-private-dir)) + (make-directory doom-private-dir 'parents) + (print! (success "Created %s") (relpath doom-private-dir))) ;; Create init.el, config.el & packages.el - (mapc (lambda (file) - (cl-destructuring-bind (filename . template) file - (if (file-exists-p! filename doom-private-dir) - (print! (warn "%s already exists, skipping") filename) - (print! (info "Creating %s%s") (relpath doom-private-dir) filename) - (with-temp-file (doom-path doom-private-dir filename) - (insert-file-contents template)) - (print! (success "Done!"))))) - `(("init.el" . ,(doom-path doom-emacs-dir "init.example.el")) - ("config.el" . ,(doom-path doom-core-dir "templates/config.example.el")) - ("packages.el" . ,(doom-path doom-core-dir "templates/packages.example.el"))))) + (print-group! + (mapc (lambda (file) + (cl-destructuring-bind (filename . template) file + (if (file-exists-p! filename doom-private-dir) + (print! (item "Skipping %s (already exists)") + (path filename)) + (print! (item "Creating %s%s") (relpath doom-private-dir) filename) + (with-temp-file (doom-path doom-private-dir filename) + (insert-file-contents template)) + (print! (success "Done!"))))) + `(("init.el" . ,(doom-path doom-emacs-dir "init.example.el")) + ("config.el" . ,(doom-path doom-core-dir "templates/config.example.el")) + ("packages.el" . ,(doom-path doom-core-dir "templates/packages.example.el")))))) ;; In case no init.el was present the first time `doom-initialize-modules' was ;; called in core.el (e.g. on first install) (doom-initialize-modules 'force 'no-config) ;; Ask if user would like an envvar file generated - (if noenv-p + (if (eq envfile? :no) (print! (warn "Not generating envvars file, as requested")) (if (file-exists-p doom-env-file) - (print! (info "Envvar file already exists, skipping")) - (when (or doom-auto-accept - (y-or-n-p "Generate an envvar file? (see `doom help env` for details)")) + (print! (item "Envvar file already exists, skipping")) + (when (or yes? (y-or-n-p "Generate an envvar file? (see `doom help env` for details)")) (doom-cli-reload-env-file 'force-p)))) ;; Install Doom packages - (if noinstall-p + (if (eq install? :no) (print! (warn "Not installing plugins, as requested")) (print! "Installing plugins") (doom-cli-packages-install)) @@ -74,16 +94,16 @@ name. e.g. (print! "Regenerating autoloads files") (doom-autoloads-reload) - (if nohooks-p + (if (eq hooks? :no) (print! (warn "Not deploying commit-msg and pre-push git hooks, as requested")) (print! "Deploying commit-msg and pre-push git hooks") (print-group! (condition-case e - (doom-cli--ci-deploy-hooks doom-auto-accept) + (doom-cli--ci-deploy-hooks yes?) ('user-error (print! (warn "%s") (error-message-string e)))))) - (cond (nofonts-p) + (cond ((eq fonts? :no)) (IS-WINDOWS (print! (warn "Doom cannot install all-the-icons' fonts on Windows!\n")) (print-group! @@ -93,8 +113,7 @@ name. e.g. " 2. Execute 'M-x all-the-icons-install-fonts' to download the fonts\n" " 3. Open the download location in windows explorer\n" " 4. Open each font file to install them")))) - ((or doom-auto-accept - (y-or-n-p "Download and install all-the-icon's fonts?")) + ((or yes? (y-or-n-p "Download and install all-the-icon's fonts?")) (require 'all-the-icons) (let ((window-system (cond (IS-MAC 'ns) (IS-LINUX 'x)))) @@ -107,3 +126,6 @@ name. e.g. (with-temp-buffer (insert-file-contents (doom-path doom-core-dir "templates/QUICKSTART_INTRO")) (print! "%s" (buffer-string))))) + +(provide 'core-cli-install) +;;; install.el ends here diff --git a/core/cli/lib/debugger.el b/core/cli/lib/debugger.el deleted file mode 100644 index 3b477093a..000000000 --- a/core/cli/lib/debugger.el +++ /dev/null @@ -1,71 +0,0 @@ -;;; core/cli/debugger.el -*- lexical-binding: t; -*- - -(cl-defun doom-cli--debugger (error data) - (cl-incf num-nonmacro-input-events) - (cl-destructuring-bind (backtrace &optional type data . rest) - (cons (doom-cli--backtrace) data) - (with-output-to! doom--cli-log-buffer - (let ((straight-error - (and (bound-and-true-p straight-process-buffer) - (stringp data) - (string-match-p (regexp-quote straight-process-buffer) - data) - (with-current-buffer (straight--process-buffer) - (split-string (buffer-string) "\n" t))))) - (cond (straight-error - (print! (error "The package manager threw an error")) - (print! (error "Last 25 lines of straight's error log:")) - (print-group! - (print! - "%s" (string-join - (seq-subseq straight-error - (max 0 (- (length straight-error) 25)) - (length straight-error)) - "\n")))) - ((print! (error "There was an unexpected error")) - (print-group! - (print! "%s %s" (bold "Message:") (get type 'error-message)) - (print! "%s %S" (bold "Error:") (append (list type data) rest)) - (when backtrace - (print! (bold "Backtrace:")) - (print-group! - (dolist (frame (seq-take backtrace 10)) - (let* ((frame (replace-regexp-in-string - "[\n\r]" "\\\\n" (prin1-to-string frame))) - (frame (if (> (length frame) 74) - (concat (substring frame 0 74) "...") - frame))) - (print! "%s" frame)))))))) - (when backtrace - (with-temp-file doom-cli-log-error-file - (insert "# -*- lisp-interaction -*-\n") - (insert "# vim: set ft=lisp:\n") - (let ((standard-output (current-buffer)) - (print-quoted t) - (print-escape-newlines t) - (print-escape-control-characters t) - (print-level nil) - (print-circle nil)) - (when straight-error - (print (string-join straight-error "\n"))) - (mapc #'print (cons (list type data) backtrace))) - (print! (warn "Extended backtrace logged to %s") - (relpath doom-cli-log-error-file))))))) - (throw 'exit 255)) - -(defun doom-cli--backtrace () - (let* ((n 0) - (frame (backtrace-frame n)) - (frame-list nil) - (in-program-stack nil)) - (while frame - (when in-program-stack - (push (cdr frame) frame-list)) - (when (eq (elt frame 1) 'doom-cli--debugger) - (setq in-program-stack t)) - (when (and (eq (elt frame 1) 'doom-cli-execute) - (eq (elt frame 2) :doom)) - (setq in-program-stack nil)) - (setq n (1+ n) - frame (backtrace-frame n))) - (reverse frame-list))) diff --git a/core/cli/lib/lib.el b/core/cli/lib/lib.el deleted file mode 100644 index b84b157a5..000000000 --- a/core/cli/lib/lib.el +++ /dev/null @@ -1,185 +0,0 @@ -;;; core/cli/lib.el --- -*- lexical-binding: t; no-byte-compile: t; -*- - -(cl-defstruct - (doom-cli - (:constructor nil) - (:constructor - make-doom-cli - (name &key desc aliases optlist arglist plist fn - &aux - (optlist - (cl-loop for (symbol options desc) in optlist - for ((_ . options) (_ . params)) - = (seq-group-by #'stringp options) - collect - (make-doom-cli-option :symbol symbol - :flags options - :args params - :desc desc)))))) - (name nil :read-only t) - (desc "TODO") - aliases - optlist - arglist - plist - (fn (lambda (_) (print! "But nobody came!")))) - -(cl-defstruct doom-cli-option - (symbol) - (flags ()) - (args ()) - (desc "TODO")) - -(defun doom--cli-get-option (cli flag) - (cl-find-if (doom-partial #'member flag) - (doom-cli-optlist cli) - :key #'doom-cli-option-flags)) - -(defun doom--cli-process (cli args) - (let* ((args (copy-sequence args)) - (arglist (copy-sequence (doom-cli-arglist cli))) - (expected - (or (cl-position-if (doom-rpartial #'memq cl--lambda-list-keywords) - arglist) - (length arglist))) - (got 0) - restvar - rest - alist) - (catch 'done - (while args - (let ((arg (pop args))) - (cond ((eq (car arglist) '&rest) - (setq restvar (cadr arglist) - rest (cons arg args)) - (throw 'done t)) - - ((string-match "^\\(--\\([a-zA-Z0-9][a-zA-Z0-9-_]*\\)\\)\\(?:=\\(.+\\)\\)?$" arg) - (let* ((fullflag (match-string 1 arg)) - (opt (doom--cli-get-option cli fullflag))) - (unless opt - (user-error "Unrecognized switch %S" (concat "--" (match-string 2 arg)))) - (setf (alist-get (doom-cli-option-symbol opt) alist) - (or (if (doom-cli-option-args opt) - (or (match-string 3 arg) - (pop args) - (user-error "%S expected an argument, but got none" - fullflag)) - (if (match-string 3 arg) - (user-error "%S was not expecting an argument, but got %S" - fullflag (match-string 3 arg)) - fullflag)))))) - - ((string-match "^\\(-\\([a-zA-Z0-9]+\\)\\)$" arg) - (let ((fullflag (match-string 1 arg)) - (flag (match-string 2 arg))) - (dolist (switch (split-string flag "" t)) - (if-let (opt (doom--cli-get-option cli (concat "-" switch))) - (setf (alist-get (doom-cli-option-symbol opt) alist) - (if (doom-cli-option-args opt) - (or (pop args) - (user-error "%S expected an argument, but got none" - fullflag)) - fullflag)) - (user-error "Unrecognized switch %S" (concat "-" switch)))))) - - (arglist - (cl-incf got) - (let ((spec (pop arglist))) - (when (eq spec '&optional) - (setq spec (pop arglist))) - (setf (alist-get spec alist) arg)) - (when (null arglist) - (throw 'done t))) - - (t - (push arg args) - (throw 'done t)))))) - (when (< got expected) - (error "Expected %d arguments, got %d" expected got)) - (when rest - (setf (alist-get restvar alist) rest)) - alist)) - -(defun doom-cli-get (command) - "Return a CLI object associated by COMMAND name (string)." - (cond ((null command) nil) - ((doom-cli-p command) command) - ((doom-cli-get - (gethash (cond ((symbolp command) command) - ((stringp command) (intern command)) - (command)) - doom--cli-commands))))) - -(defun doom-cli-internal-p (cli) - "Return non-nil if CLI is an internal (non-public) command." - (string-prefix-p ":" (doom-cli-name cli))) - -(defun doom-cli-execute (command &rest args) - "Execute COMMAND (string) with ARGS (list of strings). - -Executes a cli defined with `defcli!' with the name or alias specified by -COMMAND, and passes ARGS to it." - (if-let (cli (doom-cli-get command)) - (funcall (doom-cli-fn cli) - (doom--cli-process cli (remq nil args))) - (user-error "Couldn't find any %S command" command))) - -(defmacro defcli! (name speclist &optional docstring &rest body) - "Defines a CLI command. - -COMMAND is a symbol or a list of symbols representing the aliases for this -command. DOCSTRING is a string description; its first line should be short -(under 60 characters), as it will be used as a summary for 'doom help'. - -SPECLIST is a specification for options and arguments, which can be a list -specification for an option/switch in the following format: - - (VAR [FLAGS... ARGS...] DESCRIPTION) - -Otherwise, SPECLIST accepts the same argument specifiers as `defun'. - -BODY will be run when this dispatcher is called." - (declare (indent 2) (doc-string 3)) - (unless (stringp docstring) - (push docstring body) - (setq docstring "TODO")) - (let ((names (doom-enlist name)) - (optlist (cl-remove-if-not #'listp speclist)) - (arglist (cl-remove-if #'listp speclist)) - (plist (cl-loop for (key val) on body by #'cddr - if (keywordp key) - nconc (list key val) into plist - else return plist))) - `(let ((name ',(car names)) - (aliases ',(cdr names)) - (plist ',plist)) - (when doom--cli-group - (setq plist (plist-put plist :group doom--cli-group))) - (puthash - name - (make-doom-cli (symbol-name name) - :desc ,docstring - :aliases (mapcar #'symbol-name aliases) - :arglist ',arglist - :optlist ',optlist - :plist plist - :fn - (lambda (--alist--) - (ignore --alist--) - (let ,(cl-loop for opt in speclist - for optsym = (if (listp opt) (car opt) opt) - unless (memq optsym cl--lambda-list-keywords) - collect (list optsym `(cdr (assq ',optsym --alist--)))) - ,@body))) - doom--cli-commands) - (when aliases - (mapc (doom-rpartial #'puthash name doom--cli-commands) - aliases))))) - -(defmacro defcligroup! (name docstring &rest body) - "Declare all enclosed cli commands are part of the NAME group." - (declare (indent defun) (doc-string 2)) - `(let ((doom--cli-group ,name)) - (puthash doom--cli-group ,docstring doom--cli-groups) - ,@body)) diff --git a/core/cli/lib/straight-hacks.el b/core/cli/lib/straight-hacks.el deleted file mode 100644 index db385e81f..000000000 --- a/core/cli/lib/straight-hacks.el +++ /dev/null @@ -1,129 +0,0 @@ -;;; core/cli/straight-hacks.el --- -*- lexical-binding: t; no-byte-compile: t; -*- - -;; Straight was designed primarily for interactive use, in an interactive Emacs -;; session, but Doom does its package management in the terminal. Some things -;; must be modified get straight to behave and improve its UX for our users. - -(defvar doom--straight-auto-options - '(("has diverged from" - . "^Reset [^ ]+ to branch") - ("but recipe specifies a URL of" - . "Delete remote \"[^\"]+\", re-create it with correct URL") - ("has a merge conflict:" - . "^Abort merge$") - ("has a dirty worktree:" - . "^Discard changes$") - ("^In repository \"[^\"]+\", [^ ]+ (on branch \"main\") is ahead of default branch \"master\"" - . "^Checkout branch \"master\"") - ("^In repository \"[^\"]+\", [^ ]+ (on branch \"[^\"]+\") is ahead of default branch \"[^\"]+\"" - . "^Checkout branch \"") - ("^In repository " - . "^Reset branch \\|^Delete remote [^,]+, re-create it with correct URL")) - "A list of regexps, mapped to regexps. - -Their CAR is tested against the prompt, and CDR is tested against the presented -option, and is used by `straight-vc-git--popup-raw' to select which option to -recommend. - -It may not be obvious to users what they should do for some straight prompts, -so Doom will recommend the one that reverts a package back to its (or target) -original state.") - - -;; HACK Remove dired & magit options from prompt, since they're inaccessible in -;; noninteractive sessions. -(advice-add #'straight-vc-git--popup-raw :override #'straight--popup-raw) - -;; HACK Replace GUI popup prompts (which hang indefinitely in tty Emacs) with -;; simple prompts. -(defadvice! doom--straight-fallback-to-y-or-n-prompt-a (fn &optional prompt) - :around #'straight-are-you-sure - (or doom-auto-accept - (if doom-interactive-p - (funcall fn prompt) - (y-or-n-p (format! "%s" (or prompt "")))))) - -(defun doom--straight-recommended-option-p (prompt option) - (cl-loop for (prompt-re . opt-re) in doom--straight-auto-options - if (string-match-p prompt-re prompt) - return (string-match-p opt-re option))) - -(defadvice! doom--straight-fallback-to-tty-prompt-a (fn prompt actions) - "Modifies straight to prompt on the terminal when in noninteractive sessions." - :around #'straight--popup-raw - (if doom-interactive-p - (funcall fn prompt actions) - (let ((doom--straight-auto-options doom--straight-auto-options)) - ;; We can't intercept C-g, so no point displaying any options for this key - ;; when C-c is the proper way to abort batch Emacs. - (delq! "C-g" actions 'assoc) - ;; HACK These are associated with opening dired or magit, which isn't - ;; possible in tty Emacs, so... - (delq! "e" actions 'assoc) - (delq! "g" actions 'assoc) - (if doom-auto-discard - (cl-loop with doom-auto-accept = t - for (_key desc func) in actions - when desc - when (doom--straight-recommended-option-p prompt desc) - return (funcall func)) - (print! (start "%s") (red prompt)) - (print-group! - (terpri) - (let (recommended options) - (print-group! - (print! " 1) Abort") - (cl-loop for (_key desc func) in actions - when desc - do (push func options) - and do - (print! "%2s) %s" (1+ (length options)) - (if (doom--straight-recommended-option-p prompt desc) - (progn - (setq doom--straight-auto-options nil - recommended (length options)) - (green (concat desc " (Choose this if unsure)"))) - desc)))) - (terpri) - (let* ((options - (cons (lambda () - (let ((doom-output-indent 0)) - (terpri) - (print! (warn "Aborted"))) - (kill-emacs 1)) - (nreverse options))) - (prompt - (format! "How to proceed? (%s%s) " - (mapconcat #'number-to-string - (number-sequence 1 (length options)) - ", ") - (if (not recommended) "" - (format "; don't know? Pick %d" (1+ recommended))))) - answer fn) - (while (null (nth (setq answer (1- (read-number prompt))) - options)) - (print! (warn "%s is not a valid answer, try again.") - answer)) - (funcall (nth answer options))))))))) - -(setq straight-arrow " > ") -(defadvice! doom--straight-respect-print-indent-a (string &rest objects) - "Same as `message' (which see for STRING and OBJECTS) normally. -However, in batch mode, print to stdout instead of stderr." - :override #'straight--output - (let ((msg (apply #'format string objects))) - (save-match-data - (when (string-match (format "^%s\\(.+\\)$" (regexp-quote straight-arrow)) msg) - (setq msg (match-string 1 msg)))) - (and (string-match-p "^\\(Cloning\\|\\(Reb\\|B\\)uilding\\) " msg) - (not (string-suffix-p "...done" msg)) - (doom--print (doom--format (concat "> " msg)))))) - -(defadvice! doom--straight-ignore-gitconfig-a (fn &rest args) - "Prevent user and system git configuration from interfering with git calls." - :around #'straight--process-call - (letenv! (("GIT_CONFIG" nil) - ("GIT_CONFIG_NOSYSTEM" "1") - ("GIT_CONFIG_GLOBAL" (or (getenv "DOOMGITCONFIG") - "/dev/null"))) - (apply fn args))) diff --git a/core/cli/packages.el b/core/cli/packages.el index 32dbaa3b1..4f78d64f5 100644 --- a/core/cli/packages.el +++ b/core/cli/packages.el @@ -1,37 +1,39 @@ -;; -*- no-byte-compile: t; -*- -;;; core/cli/packages.el +;;; core/cli/packages.el --- package management commands -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: -(require 'comp nil t) +;; +;;; Variables + +;; None yet! ;; ;;; Commands -(defcli! (update u) (&rest _) - "This command was removed." - :hidden t - (print! (error "This command has been removed.\n")) - (print-group! - (print! "To update Doom run 'doom upgrade'. To only update packages run 'doom sync -u'.")) - nil) +(defcli! (:before (build b purge p)) (&context context) + (require 'comp nil t) + (doom-initialize-core-packages)) -(defcli! (build b) - ((rebuild-p ["-r"] "Only rebuild packages that need rebuilding")) +;; DEPRECATED Replace with "doom sync --rebuild" +(defcli! ((build b)) + ((rebuild-p ("-r") "Only rebuild packages that need rebuilding")) "Byte-compiles & symlinks installed packages. This ensures that all needed files are symlinked from their package repo and their elisp files are byte-compiled. This is especially necessary if you upgrade Emacs (as byte-code is generally not forward-compatible)." - (when (doom-cli-packages-build (not rebuild-p)) + (when (doom-packages-build (not rebuild-p)) (doom-autoloads-reload)) t) -(defcli! (purge p) - ((nobuilds-p ["-b" "--no-builds"] "Don't purge unneeded (built) packages") - (noelpa-p ["-p" "--no-elpa"] "Don't purge ELPA packages") - (norepos-p ["-r" "--no-repos"] "Don't purge unused straight repos") - (noeln-p ["-e" "--no-eln"] "Don't purge old ELN bytecode") - (noregraft-p ["-g" "--no-regraft"] "Regraft git repos (ie. compact them)")) +;; TODO Rename to "doom gc" and move to its own file +(defcli! ((purge p)) + ((nobuilds-p ("-b" "--no-builds") "Don't purge unneeded (built) packages") + (noelpa-p ("-p" "--no-elpa") "Don't purge ELPA packages") + (norepos-p ("-r" "--no-repos") "Don't purge unused straight repos") + (noeln-p ("-e" "--no-eln") "Don't purge old ELN bytecode") + (noregraft-p ("-g" "--no-regraft") "Regraft git repos (ie. compact them)")) "Deletes orphaned packages & repos, and compacts them. Purges all installed ELPA packages (as they are considered temporary). Purges @@ -42,7 +44,7 @@ possible. It is a good idea to occasionally run this doom purge -g to ensure your package list remains lean." (straight-check-all) - (when (doom-cli-packages-purge + (when (doom-packages-purge (not noelpa-p) (not norepos-p) (not nobuilds-p) @@ -51,24 +53,24 @@ list remains lean." (doom-autoloads-reload)) t) -;; (defcli! rollback () ; TODO doom rollback -;; "" -;; (user-error "Not implemented yet, sorry!")) +(defcli! rollback () :stub t) ; TODO Implement me post-3.0 ;; ;;; Library -(defun doom--same-commit-p (abbrev-ref ref) +;; FIXME Enforce naming conventions for all functions below + +(defun doom-packages--same-commit-p (abbrev-ref ref) (and (stringp abbrev-ref) (stringp ref) (string-match-p (concat "^" (regexp-quote abbrev-ref)) ref))) -(defun doom--abbrev-commit (commit &optional full) +(defun doom-packages--abbrev-commit (commit &optional full) (if full commit (substring commit 0 7))) -(defun doom--commit-log-between (start-ref end-ref) +(defun doom-packages--commit-log-between (start-ref end-ref) (straight--process-with-result (straight--process-run "git" "log" "--oneline" "--no-merges" @@ -77,7 +79,7 @@ list remains lean." (string-trim-right (or stdout "")) (format "ERROR: Couldn't collect commit list because: %s" stderr)))) -(defmacro doom--straight-with (form &rest body) +(defmacro doom-packages--straight-with (form &rest body) (declare (indent 1)) `(let-alist (let* ((buffer (straight--process-buffer)) @@ -94,12 +96,12 @@ list remains lean." "\n+\\[Return code: [0-9-]+\\]\n+"))))) ,@body)) -(defun doom--barf-if-incomplete-packages () +(defun doom-packages--barf-if-incomplete () (let ((straight-safe-mode t)) (condition-case _ (straight-check-all) (error (user-error "Package state is incomplete. Run 'doom sync' first"))))) -(defmacro doom--with-package-recipes (recipes binds &rest body) +(defmacro doom-packages--with-recipes (recipes binds &rest body) (declare (indent 2)) (let ((recipe-var (make-symbol "recipe")) (recipes-var (make-symbol "recipes"))) @@ -114,14 +116,14 @@ list remains lean." ,(doom-enlist binds) ,@body)))))) -(defvar doom--cli-updated-recipes nil) -(defun doom--cli-recipes-update () +(defvar doom-packages--cli-updated-recipes nil) +(defun doom-packages--cli-recipes-update () "Updates straight and recipe repos." - (unless doom--cli-updated-recipes + (unless doom-packages--cli-updated-recipes (straight--make-build-cache-available) (print! (start "Updating recipe repos...")) (print-group! - (doom--with-package-recipes + (doom-packages--with-recipes (delq nil (mapcar (doom-rpartial #'gethash straight--repo-cache) (mapcar #'symbol-name straight-recipe-repositories))) @@ -130,39 +132,39 @@ list remains lean." (ref (straight-vc-get-commit type local-repo)) newref output) (print! (start "\033[KUpdating recipes for %s...%s") package esc) - (doom--straight-with (straight-vc-fetch-from-remote recipe) + (doom-packages--straight-with (straight-vc-fetch-from-remote recipe) (when .it (setq output .output) (straight-merge-package package) (unless (equal ref (setq newref (straight-vc-get-commit type local-repo))) (print! (success "\033[K%s updated (%s -> %s)") package - (doom--abbrev-commit ref) - (doom--abbrev-commit newref)) + (doom-packages--abbrev-commit ref) + (doom-packages--abbrev-commit newref)) (unless (string-empty-p output) - (print-group! (print! (info "%s" output)))))))))) + (print-group! (print! (item "%s" output)))))))))) (setq straight--recipe-lookup-cache (make-hash-table :test #'eq) - doom--cli-updated-recipes t))) + doom-packages--cli-updated-recipes t))) -(defvar doom--eln-output-expected nil) +(defvar doom-packages--eln-output-expected nil) -(defvar doom--eln-output-path (car (bound-and-true-p native-comp-eln-load-path))) +(defvar doom-packages--eln-output-path (car (bound-and-true-p native-comp-eln-load-path))) -(defun doom--eln-file-name (file) +(defun doom-packages--eln-file-name (file) "Return the short .eln file name corresponding to `file'." (concat comp-native-version-dir "/" (file-name-nondirectory (comp-el-to-eln-filename file)))) -(defun doom--eln-output-file (eln-name) +(defun doom-packages--eln-output-file (eln-name) "Return the expected .eln file corresponding to `eln-name'." - (concat doom--eln-output-path eln-name)) + (concat doom-packages--eln-output-path eln-name)) -(defun doom--eln-error-file (eln-name) +(defun doom-packages--eln-error-file (eln-name) "Return the expected .error file corresponding to `eln-name'." - (concat doom--eln-output-path eln-name ".error")) + (concat doom-packages--eln-output-path eln-name ".error")) -(defun doom--find-eln-file (eln-name) +(defun doom-packages--find-eln-file (eln-name) "Find `eln-name' on the `native-comp-eln-load-path'." (cl-some (lambda (eln-path) (let ((file (concat eln-path eln-name))) @@ -170,7 +172,7 @@ list remains lean." file))) native-comp-eln-load-path)) -(defun doom--elc-file-outdated-p (file) +(defun doom-packages--elc-file-outdated-p (file) "Check whether the corresponding .elc for `file' is outdated." (let ((elc-file (byte-compile-dest-file file))) ;; NOTE Ignore missing elc files, they could be missing due to @@ -180,11 +182,11 @@ list remains lean." (doom-log "%s is newer than %s" file elc-file) t))) -(defun doom--eln-file-outdated-p (file) +(defun doom-packages--eln-file-outdated-p (file) "Check whether the corresponding .eln for `file' is outdated." - (let* ((eln-name (doom--eln-file-name file)) - (eln-file (doom--find-eln-file eln-name)) - (error-file (doom--eln-error-file eln-name))) + (let* ((eln-name (doom-packages--eln-file-name file)) + (eln-file (doom-packages--find-eln-file eln-name)) + (error-file (doom-packages--eln-error-file eln-name))) (cond (eln-file (when (file-newer-than-file-p file eln-file) (doom-log "%s is newer than %s" file eln-file) @@ -197,28 +199,28 @@ list remains lean." (doom-log "%s doesn't exist" eln-name) t)))) -(defun doom--native-compile-done-h (file) +(defun doom-packages--native-compile-done-h (file) "Callback fired when an item has finished async compilation." (when file - (let* ((eln-name (doom--eln-file-name file)) - (eln-file (doom--eln-output-file eln-name)) - (error-file (doom--eln-error-file eln-name))) + (let* ((eln-name (doom-packages--eln-file-name file)) + (eln-file (doom-packages--eln-output-file eln-name)) + (error-file (doom-packages--eln-error-file eln-name))) (if (file-exists-p eln-file) (doom-log "Compiled %s" eln-file) (make-directory (file-name-directory error-file) 'parents) (write-region "" nil error-file) (doom-log "Wrote %s" error-file))))) -(defun doom--native-compile-jobs () +(defun doom-packages--native-compile-jobs () "How many async native compilation jobs are queued or in-progress." (if (featurep 'comp) (+ (length comp-files-queue) (comp-async-runnings)) 0)) -(defun doom--wait-for-native-compile-jobs () +(defun doom-packages--wait-for-native-compile-jobs () "Wait for all pending async native compilation jobs." - (cl-loop for pending = (doom--native-compile-jobs) + (cl-loop for pending = (doom-packages--native-compile-jobs) with previous = 0 while (not (zerop pending)) if (/= previous pending) do @@ -228,21 +230,21 @@ list remains lean." (let ((inhibit-message t)) (sleep-for 0.1)))) -(defun doom--write-missing-eln-errors () +(defun doom-packages--write-missing-eln-errors () "Write .error files for any expected .eln files that are missing." (when NATIVECOMP - (cl-loop for file in doom--eln-output-expected - for eln-name = (doom--eln-file-name file) - for eln-file = (doom--eln-output-file eln-name) - for error-file = (doom--eln-error-file eln-name) + (cl-loop for file in doom-packages--eln-output-expected + for eln-name = (doom-packages--eln-file-name file) + for eln-file = (doom-packages--eln-output-file eln-name) + for error-file = (doom-packages--eln-error-file eln-name) unless (or (file-exists-p eln-file) (file-newer-than-file-p error-file file)) do (make-directory (file-name-directory error-file) 'parents) (write-region "" nil error-file) (doom-log "Wrote %s" error-file)) - (setq doom--eln-output-expected nil))) + (setq doom-packages--eln-output-expected nil))) -(defun doom--compile-site-packages () +(defun doom-packages--compile-site-files () "Queue async compilation for all non-doom Elisp files." (when NATIVECOMP (cl-loop with paths = (cl-loop for path in load-path @@ -250,14 +252,14 @@ list remains lean." collect path) for file in (doom-files-in paths :match "\\.el\\(?:\\.gz\\)?$") if (and (file-exists-p (byte-compile-dest-file file)) - (not (doom--find-eln-file (doom--eln-file-name file))) + (not (doom-packages--find-eln-file (doom-packages--eln-file-name file))) (not (cl-some (lambda (re) (string-match-p re file)) native-comp-deferred-compilation-deny-list))) do (doom-log "Compiling %s" file) (native-compile-async file)))) -(defun doom-cli-packages-install () +(defun doom-packages-install () "Installs missing packages. This function will install any primary package (i.e. a package with a `package!' @@ -266,17 +268,17 @@ declaration) or dependency thereof that hasn't already been." (print! (start "Installing packages...")) (let ((pinned (doom-package-pinned-list))) (print-group! - (add-hook 'native-comp-async-cu-done-functions #'doom--native-compile-done-h) + (add-hook 'native-comp-async-cu-done-functions #'doom-packages--native-compile-done-h) (if-let (built - (doom--with-package-recipes (doom-package-recipe-list) + (doom-packages--with-recipes (doom-package-recipe-list) (recipe package type local-repo) (unless (file-directory-p (straight--repos-dir local-repo)) - (doom--cli-recipes-update)) + (doom-packages--cli-recipes-update)) (condition-case-unless-debug e (let ((straight-use-package-pre-build-functions (cons (lambda (pkg &rest _) (when-let (commit (cdr (assoc pkg pinned))) - (print! (info "Checked out %s: %s") pkg commit))) + (print! (item "Checked out %s: %s") pkg commit))) straight-use-package-pre-build-functions))) (straight-use-package (intern package)) ;; HACK Line encoding issues can plague repos with dirty @@ -291,16 +293,16 @@ declaration) or dependency thereof that hasn't already been." (error (signal 'doom-package-error (list package e)))))) (progn - (doom--compile-site-packages) + (doom-packages--compile-site-files) (when NATIVECOMP - (doom--wait-for-native-compile-jobs) - (doom--write-missing-eln-errors)) + (doom-packages--wait-for-native-compile-jobs) + (doom-packages--write-missing-eln-errors)) (print! (success "\033[KInstalled %d packages") (length built))) - (print! (info "No packages need to be installed")) + (print! (item "No packages need to be installed")) nil)))) -(defun doom-cli-packages-build (&optional force-p) +(defun doom-packages-build (&optional force-p) "(Re)build all packages." (doom-initialize-packages) (print! (start "(Re)building %spackages...") (if force-p "all " "")) @@ -318,11 +320,11 @@ declaration) or dependency thereof that hasn't already been." (or (if force-p :all straight--packages-to-rebuild) (make-hash-table :test #'equal))) (recipes (doom-package-recipe-list))) - (add-hook 'native-comp-async-cu-done-functions #'doom--native-compile-done-h) + (add-hook 'native-comp-async-cu-done-functions #'doom-packages--native-compile-done-h) (unless force-p (straight--make-build-cache-available)) (if-let (built - (doom--with-package-recipes recipes (package local-repo recipe) + (doom-packages--with-recipes recipes (package local-repo recipe) (unless force-p ;; Ensure packages with outdated files/bytecode are rebuilt (let* ((build-dir (straight--build-dir package)) @@ -346,19 +348,19 @@ declaration) or dependency thereof that hasn't already been." (file-exists-p (straight--modified-dir (or local-repo package))) (cl-loop with outdated = nil for file in (doom-files-in build-dir :match "\\.el$" :full t) - if (or (if want-byte-compile (doom--elc-file-outdated-p file)) - (if want-native-compile (doom--eln-file-outdated-p file))) + if (or (if want-byte-compile (doom-packages--elc-file-outdated-p file)) + (if want-native-compile (doom-packages--eln-file-outdated-p file))) do (setq outdated t) (when want-native-compile - (push file doom--eln-output-expected)) + (push file doom-packages--eln-output-expected)) finally return outdated)) (puthash package t straight--packages-to-rebuild)))) (straight-use-package (intern package)))) (progn - (doom--compile-site-packages) + (doom-packages--compile-site-files) (when NATIVECOMP - (doom--wait-for-native-compile-jobs) - (doom--write-missing-eln-errors)) + (doom-packages--wait-for-native-compile-jobs) + (doom-packages--write-missing-eln-errors)) ;; HACK Every time you save a file in a package that straight tracks, ;; it is recorded in ~/.emacs.d/.local/straight/modified/. ;; Typically, straight will clean these up after rebuilding, but @@ -367,16 +369,16 @@ declaration) or dependency thereof that hasn't already been." ;; sync' or similar is run, so we clean it up ourselves: (delete-directory (straight--modified-dir) 'recursive) (print! (success "\033[KRebuilt %d package(s)") (length built))) - (print! (info "No packages need rebuilding")) + (print! (item "No packages need rebuilding")) nil)))) -(defun doom-cli-packages-update () +(defun doom-packages-update () "Updates packages." (doom-initialize-packages) - (doom--barf-if-incomplete-packages) - (doom--cli-recipes-update) + (doom-packages--barf-if-incomplete) + (doom-packages--cli-recipes-update) (let* ((repo-dir (straight--repos-dir)) (pinned (doom-package-pinned-list)) (recipes (doom-package-recipe-list)) @@ -387,7 +389,7 @@ declaration) or dependency thereof that hasn't already been." (i 0) errors) (print! (start "Updating packages (this may take a while)...")) - (doom--with-package-recipes recipes (recipe package type local-repo) + (doom-packages--with-recipes recipes (recipe package type local-repo) (cl-incf i) (print-group! (unless (straight--repository-is-available-p recipe) @@ -414,30 +416,37 @@ declaration) or dependency thereof that hasn't already been." (or (cond ((not (stringp target-ref)) (print! (start "\033[K(%d/%d) Fetching %s...%s") i total package esc) - (doom--straight-with (straight-vc-fetch-from-remote recipe) + (doom-packages--straight-with (straight-vc-fetch-from-remote recipe) (when .it (straight-merge-package package) + ;; (condition-case e + ;; (straight-merge-package package) + ;; (wrong-type-argument + ;; (if (not (equal (cdr e) '(arrayp nil))) + ;; (signal (car e) (cdr e)) + ;; (delete-directory (straight--build-dir local-repo) t) + ;; (straight-use-package (intern package))))) (setq target-ref (straight-vc-get-commit type local-repo)) - (setq output (doom--commit-log-between ref target-ref) + (setq output (doom-packages--commit-log-between ref target-ref) commits (length (split-string output "\n" t))) - (or (not (doom--same-commit-p target-ref ref)) + (or (not (doom-packages--same-commit-p target-ref ref)) (cl-return))))) - ((doom--same-commit-p target-ref ref) - (print! (info "\033[K(%d/%d) %s is up-to-date...%s") i total package esc) + ((doom-packages--same-commit-p target-ref ref) + (print! (item "\033[K(%d/%d) %s is up-to-date...%s") i total package esc) (cl-return)) ((if (straight-vc-commit-present-p recipe target-ref) (print! (start "\033[K(%d/%d) Checking out %s (%s)...%s") - i total package (doom--abbrev-commit target-ref) esc) + i total package (doom-packages--abbrev-commit target-ref) esc) (print! (start "\033[K(%d/%d) Fetching %s...%s") i total package esc) (and (straight-vc-fetch-from-remote recipe) (straight-vc-commit-present-p recipe target-ref))) (straight-vc-check-out-commit recipe target-ref) (or (not (eq type 'git)) - (setq output (doom--commit-log-between ref target-ref) + (setq output (doom-packages--commit-log-between ref target-ref) commits (length (split-string output "\n" t)))) - (doom--same-commit-p target-ref (straight-vc-get-commit type local-repo))) + (doom-packages--same-commit-p target-ref (straight-vc-get-commit type local-repo))) ((print! (start "\033[K(%d/%d) Re-cloning %s...") i total local-repo esc) (let ((repo (straight--repos-dir local-repo)) @@ -447,20 +456,20 @@ declaration) or dependency thereof that hasn't already been." (straight-use-package (intern package) nil 'no-build)) (prog1 (file-directory-p repo) (or (not (eq type 'git)) - (setq output (doom--commit-log-between ref target-ref) + (setq output (doom-packages--commit-log-between ref target-ref) commits (length (split-string output "\n" t)))))))) (progn (print! (warn "\033[K(%d/%d) Failed to fetch %s") i total local-repo) (unless (string-empty-p output) - (print-group! (print! (info "%s" output)))) + (print-group! (print! (item "%s" output)))) (cl-return))) (puthash local-repo t repos-to-rebuild) (puthash package t packages-to-rebuild) (print! (success "\033[K(%d/%d) %s: %s -> %s%s") i total local-repo - (doom--abbrev-commit ref) - (doom--abbrev-commit target-ref) + (doom-packages--abbrev-commit ref) + (doom-packages--abbrev-commit target-ref) (if (and (integerp commits) (> commits 0)) (format " [%d commit(s)]" commits) "")) @@ -471,7 +480,7 @@ declaration) or dependency thereof that hasn't already been." (concat (string-join (cl-subseq (butlast lines 1) 0 20) "\n") "\n[...]") output))) - (print-group! (print! "%s" (indent 2 output))))) + (print-group! (print! "%s" (indent output 2))))) (user-error (signal 'user-error (error-message-string e))) (error @@ -486,12 +495,12 @@ declaration) or dependency thereof that hasn't already been." (hash-table-keys packages-to-rebuild))) (print! (success "Updated %d package(s)") (hash-table-count packages-to-rebuild)) - (doom-cli-packages-build) + (doom-packages-build) t)))) ;;; PURGE (for the emperor) -(defun doom--cli-packages-purge-build (build) +(defun doom-packages--purge-build (build) (let ((build-dir (straight--build-dir build))) (delete-directory build-dir 'recursive) (if (file-directory-p build-dir) @@ -499,16 +508,16 @@ declaration) or dependency thereof that hasn't already been." (print! (success "Purged build/%s" build)) t))) -(defun doom--cli-packages-purge-builds (builds) +(defun doom-packages--purge-builds (builds) (if (not builds) (prog1 0 - (print! (info "No builds to purge"))) + (print! (item "No builds to purge"))) (print! (start "Purging straight builds..." (length builds))) (print-group! (length - (delq nil (mapcar #'doom--cli-packages-purge-build builds)))))) + (delq nil (mapcar #'doom-packages--purge-build builds)))))) -(cl-defun doom--cli-packages-regraft-repo (repo) +(cl-defun doom-packages--regraft-repo (repo) (unless repo (error "No repo specified for regrafting")) (let ((default-directory (straight--repos-dir repo))) @@ -522,7 +531,7 @@ declaration) or dependency thereof that hasn't already been." (doom-call-process "git" "reset" "--hard") (doom-call-process "git" "clean" "-ffd") (if (not (zerop (car (doom-call-process "git" "replace" "--graft" "HEAD")))) - (print! (info "\033[Krepos/%s is already compact\033[1A" repo)) + (print! (item "\033[Krepos/%s is already compact\033[1A" repo)) (doom-call-process "git" "reflog" "expire" "--expire=all" "--all") (doom-call-process "git" "gc" "--prune=now") (let ((after-size (doom-directory-size default-directory))) @@ -532,21 +541,21 @@ declaration) or dependency thereof that hasn't already been." repo before-size after-size))))) t)) -(defun doom--cli-packages-regraft-repos (repos) +(defun doom-packages--regraft-repos (repos) (if (not repos) (prog1 0 - (print! (info "No repos to regraft"))) + (print! (item "No repos to regraft"))) (print! (start "Regrafting %d repos..." (length repos))) (let ((before-size (doom-directory-size (straight--repos-dir)))) (print-group! - (prog1 (delq nil (mapcar #'doom--cli-packages-regraft-repo repos)) + (prog1 (delq nil (mapcar #'doom-packages--regraft-repo repos)) (princ "\033[K") (let ((after-size (doom-directory-size (straight--repos-dir)))) (print! (success "Finished regrafting. Size before: %0.1fKB and after: %0.1fKB (%0.1fKB)") before-size after-size (- after-size before-size)))))))) -(defun doom--cli-packages-purge-repo (repo) +(defun doom-packages--purge-repo (repo) (let ((repo-dir (straight--repos-dir repo))) (when (file-directory-p repo-dir) (delete-directory repo-dir 'recursive) @@ -556,21 +565,21 @@ declaration) or dependency thereof that hasn't already been." (print! (success "Purged repos/%s" repo)) t)))) -(defun doom--cli-packages-purge-repos (repos) +(defun doom-packages--purge-repos (repos) (if (not repos) (prog1 0 - (print! (info "No repos to purge"))) + (print! (item "No repos to purge"))) (print! (start "Purging straight repositories...")) (print-group! (length - (delq nil (mapcar #'doom--cli-packages-purge-repo repos)))))) + (delq nil (mapcar #'doom-packages--purge-repo repos)))))) -(defun doom--cli-packages-purge-elpa () +(defun doom-packages--purge-elpa () (require 'core-packages) (let ((dirs (doom-files-in package-user-dir :type t :depth 0))) (if (not dirs) (prog1 0 - (print! (info "No ELPA packages to purge"))) + (print! (item "No ELPA packages to purge"))) (print! (start "Purging ELPA packages...")) (dolist (path dirs (length dirs)) (condition-case e @@ -584,23 +593,23 @@ declaration) or dependency thereof that hasn't already been." (filename path) e))))))) -(defun doom--cli-packages-purge-eln () +(defun doom-packages--purge-eln () (if-let (dirs - (cl-delete (expand-file-name comp-native-version-dir doom--eln-output-path) - (directory-files doom--eln-output-path t "^[^.]" t) + (cl-delete (expand-file-name comp-native-version-dir doom-packages--eln-output-path) + (directory-files doom-packages--eln-output-path t "^[^.]" t) :test #'file-equal-p)) (progn (print! (start "Purging old native bytecode...")) (print-group! (dolist (dir dirs) - (print! (info "Deleting %S") (relpath dir doom--eln-output-path)) + (print! (item "Deleting %S") (relpath dir doom-packages--eln-output-path)) (delete-directory dir 'recursive)) (print! (success "Purged %d directory(ies)" (length dirs)))) (length dirs)) - (print! (info "No ELN directories to purge")) + (print! (item "No ELN directories to purge")) 0)) -(defun doom-cli-packages-purge (&optional elpa-p builds-p repos-p regraft-repos-p eln-p) +(defun doom-packages-purge (&optional elpa-p builds-p repos-p regraft-repos-p eln-p) "Auto-removes orphaned packages and repos. An orphaned package is a package that isn't a primary package (i.e. doesn't have @@ -610,7 +619,7 @@ If BUILDS-P, include straight package builds. If REPOS-P, include straight repos. If ELPA-P, include packages installed with package.el (M-x package-install)." (doom-initialize-packages) - (doom--barf-if-incomplete-packages) + (doom-packages--barf-if-incomplete) (print! (start "Purging orphaned packages (for the emperor)...")) (cl-destructuring-bind (&optional builds-to-purge repos-to-purge repos-to-regraft) (let ((rdirs @@ -631,19 +640,158 @@ If ELPA-P, include packages installed with package.el (M-x package-install)." (delq nil (list (if (not builds-p) - (ignore (print! (info "Skipping builds"))) - (and (/= 0 (doom--cli-packages-purge-builds builds-to-purge)) + (ignore (print! (item "Skipping builds"))) + (and (/= 0 (doom-packages--purge-builds builds-to-purge)) (straight-prune-build-cache))) (if (not elpa-p) - (ignore (print! (info "Skipping elpa packages"))) - (/= 0 (doom--cli-packages-purge-elpa))) + (ignore (print! (item "Skipping elpa packages"))) + (/= 0 (doom-packages--purge-elpa))) (if (not repos-p) - (ignore (print! (info "Skipping repos"))) - (/= 0 (doom--cli-packages-purge-repos repos-to-purge))) + (ignore (print! (item "Skipping repos"))) + (/= 0 (doom-packages--purge-repos repos-to-purge))) (if (not regraft-repos-p) - (ignore (print! (info "Skipping regrafting"))) - (doom--cli-packages-regraft-repos repos-to-regraft)) + (ignore (print! (item "Skipping regrafting"))) + (doom-packages--regraft-repos repos-to-regraft)) (when NATIVECOMP (if (not eln-p) - (ignore (print! (info "Skipping native bytecode"))) - (doom--cli-packages-purge-eln)))))))) + (ignore (print! (item "Skipping native bytecode"))) + (doom-packages--purge-eln)))))))) + + +;; +;;; Hacks + +;; Straight was designed primarily for interactive use, in an interactive Emacs +;; session, but Doom does its package management in the terminal. Some things +;; must be modified get straight to behave and improve its UX for our users. + +(defvar doom-cli--straight-auto-options + '(("has diverged from" + . "^Reset [^ ]+ to branch") + ("but recipe specifies a URL of" + . "Delete remote \"[^\"]+\", re-create it with correct URL") + ("has a merge conflict:" + . "^Abort merge$") + ("has a dirty worktree:" + . "^Discard changes$") + ("^In repository \"[^\"]+\", [^ ]+ (on branch \"main\") is ahead of default branch \"master\"" + . "^Checkout branch \"master\"") + ("^In repository \"[^\"]+\", [^ ]+ (on branch \"[^\"]+\") is ahead of default branch \"[^\"]+\"" + . "^Checkout branch \"") + ("^In repository " + . "^Reset branch \\|^Delete remote [^,]+, re-create it with correct URL")) + "A list of regexps, mapped to regexps. + +Their CAR is tested against the prompt, and CDR is tested against the presented +option, and is used by `straight-vc-git--popup-raw' to select which option to +recommend. + +It may not be obvious to users what they should do for some straight prompts, +so Doom will recommend the one that reverts a package back to its (or target) +original state.") + +;; FIXME Replace with a -j/--jobs option in 'doom sync' et co +(defadvice! doom-cli--comp-use-all-cores-a (&rest _) + "Default to using all cores, rather than half. +Doom compiles packages ahead-of-time, in a dedicated noninteractive session, so +it doesn't make sense to slack." + :before #'comp-effective-async-max-jobs + (setq comp-num-cpus (doom-system-cpus))) + +;; HACK Remove dired & magit options from prompt, since they're inaccessible in +;; noninteractive sessions. +(advice-add #'straight-vc-git--popup-raw :override #'straight--popup-raw) + +;; HACK Replace GUI popup prompts (which hang indefinitely in tty Emacs) with +;; simple prompts. +(defadvice! doom-cli--straight-fallback-to-y-or-n-prompt-a (fn &optional prompt noprompt?) + :around #'straight-are-you-sure + (or noprompt? + (if doom-interactive-p + (funcall fn prompt) + (y-or-n-p (format! "%s" (or prompt "")))))) + +(defun doom-cli--straight-recommended-option-p (prompt option) + (cl-loop for (prompt-re . opt-re) in doom-cli--straight-auto-options + if (string-match-p prompt-re prompt) + return (string-match-p opt-re option))) + +(defadvice! doom-cli--straight-fallback-to-tty-prompt-a (fn prompt actions) + "Modifies straight to prompt on the terminal when in noninteractive sessions." + :around #'straight--popup-raw + (if (bound-and-true-p async-in-child-emacs) + (error "Straight prompt: %s" prompt) + (let ((doom-cli--straight-auto-options doom-cli--straight-auto-options)) + ;; We can't intercept C-g, so no point displaying any options for this key + ;; when C-c is the proper way to abort batch Emacs. + (delq! "C-g" actions 'assoc) + ;; HACK These are associated with opening dired or magit, which isn't + ;; possible in tty Emacs, so... + (delq! "e" actions 'assoc) + (delq! "g" actions 'assoc) + (if (doom-cli-context-suppress-prompts-p doom-cli--context) + (cl-loop for (_key desc func) in actions + when desc + when (doom-cli--straight-recommended-option-p prompt desc t) + return (funcall func)) + (print! (start "%s") (red prompt)) + (print-group! + (terpri) + (let (recommended options) + (print-group! + (print! " 1) Abort") + (cl-loop for (_key desc func) in actions + when desc + do (push func options) + and do + (print! "%2s) %s" (1+ (length options)) + (if (doom-cli--straight-recommended-option-p prompt desc) + (progn + (setq doom-cli--straight-auto-options nil + recommended (length options)) + (green (concat desc " (Choose this if unsure)"))) + desc)))) + (terpri) + (let* ((options + (cons (lambda () + (let ((doom-output-indent 0)) + (terpri) + (print! (warn "Aborted"))) + (doom-cli--exit 1)) + (nreverse options))) + (prompt + (format! "How to proceed? (%s%s) " + (mapconcat #'number-to-string + (number-sequence 1 (length options)) + ", ") + (if (not recommended) "" + (format "; don't know? Pick %d" (1+ recommended))))) + answer fn) + (while (null (nth (setq answer (1- (read-number prompt))) options)) + (print! (warn "%s is not a valid answer, try again.") answer)) + (funcall (nth answer options))))))))) + +(setq straight-arrow " > ") +(defadvice! doom-cli--straight-respect-print-indent-a (string &rest objects) + "Same as `message' (which see for STRING and OBJECTS) normally. +However, in batch mode, print to stdout instead of stderr." + :override #'straight--output + (let ((msg (apply #'format string objects))) + (save-match-data + (when (string-match (format "^%s\\(.+\\)$" (regexp-quote straight-arrow)) msg) + (setq msg (match-string 1 msg)))) + (and (string-match-p "^\\(Cloning\\|\\(Reb\\|B\\)uilding\\) " msg) + (not (string-suffix-p "...done" msg)) + (doom-print (concat "> " msg))))) + +(defadvice! doom-cli--straight-ignore-gitconfig-a (fn &rest args) + "Prevent user and system git configuration from interfering with git calls." + :around #'straight--process-call + (letenv! (("GIT_CONFIG" nil) + ("GIT_CONFIG_NOSYSTEM" "1") + ("GIT_CONFIG_GLOBAL" (or (getenv "DOOMGITCONFIG") + "/dev/null"))) + (apply fn args))) + +(provide 'core-cli-packages) +;;; packages.el ends here diff --git a/core/cli/run.el b/core/cli/run.el new file mode 100644 index 000000000..b901ff316 --- /dev/null +++ b/core/cli/run.el @@ -0,0 +1,103 @@ +;;; core/cli/run.el --- launching Emacs in a sandbox -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: + +;; +;;; Variables + +;; None yet! + + +;; +;;; Commands + +(defcli! run + (;; TODO Implement sandbox functionality post-3.0 + ;; (daemon? ("--daemon")) + ;; (window-type ("--gui" "--tty")) + ;; (version ("--with-emacs" version)) + ;; (doomversion ("--with-doom" version)) + ;; (profile ("--profile" name)) + (repl? ("--repl") "Launch an elisp REPL") + ;; &multiple + ;; (calls ("-f" "--funcall" fn)) + ;; (loads ("-l" "--load" file)) + ;; (evals ( "--eval" form)) + &context context + &input input + &rest args) + "Launch Doom Emacs or an Emacs sandbox + +Opens from bin/doom's parent directory. + +Keep in mind there is some overhead opening Doom this way. For the best +performance, it is best to run Doom out of ~/.config/emacs or ~/.emacs.d." + :benchmark nil + ;; TODO Implement sandbox functionality post-3.0 + ;; (when version + ;; (unless (executable-find "nix-shell") + ;; (user-error "--emacs option is not supported without nix")) + ;; ...) + (if repl? + (if input + ;; Evaluate piped-in text directly, if given. + (eval (read input) t) + (doom-run-repl context)) + ;; TODO Does this work on Windows? + (let* ((tempdir (doom-path (temporary-file-directory) "doom.run")) + (tempemacsdir (doom-path tempdir ".emacs.d"))) + (delete-directory tempdir t) + (make-directory tempemacsdir t) + (with-temp-file (doom-path tempemacsdir "early-init.el") + (prin1 `(progn + (setenv "HOME" ,(getenv "HOME")) + (setq user-emacs-directory ,doom-emacs-dir) + (load-file ,(doom-path doom-emacs-dir "early-init.el"))) + (current-buffer))) + (exit! (format "HOME=%S %s %s" + tempdir + invocation-name + (combine-and-quote-strings args)))))) + + +;; +;;; Helpers + +(defun doom-run-repl (context) + "Launch a rudimentary Elisp REPL." + ;; I wrote this for fun; not with any serious intention of adding a + ;; fully-fledged REPL to the Doom CLI. Still, I occasionally need to check + ;; something, and once this has nix integration and can sandbox Emacs versions + ;; separately, it may be useful for quick tests and demos. + (let (form) + (while (setq form (read-from-minibuffer "(elisp) $ ")) + (when (member form '(":quit" ":q")) + (print! "\nGoodbye!") + (exit! 0)) + (let (debug-on-error) + (condition-case e + (print! "%S" (eval (read form) t)) + (error + (let* ((n 0) + (frame (backtrace-frame n)) + (frame-list nil) + (in-program-stack t)) + (while frame + (when in-program-stack + (push (cdr frame) frame-list)) + ;; (when (eq (elt frame 1) 'doom-run-repl) + ;; (setq in-program-stack t)) + (when (eq (elt frame 1) 'doom-run-repl) + (setq in-program-stack nil)) + (setq n (1+ n) + frame (backtrace-frame n))) + (let* ((depth doom-cli-backtrace-depth) + (print-escape-newlines t)) + (print! (error "There was an unexpected error")) + (print-group! + (print! "%s %s" (bold "Message:") (error-message-string e)) + (print! "%s %S" (bold "Details:") (cdr e)))))))) + (terpri)))) + +(provide 'core-cli-run) +;;; run.el ends here diff --git a/core/cli/sync.el b/core/cli/sync.el index 8af3ca4c2..a4bee219a 100644 --- a/core/cli/sync.el +++ b/core/cli/sync.el @@ -1,10 +1,30 @@ -;;; core/cli/sync.el -*- lexical-binding: t; -*- +;;; core/cli/sync.el --- synchronize config command -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: -(defcli! (sync s) - ((no-envvar-p ["-e"] "Don't regenerate the envvar file") - (no-elc-p ["-c"] "Don't recompile config") - (update-p ["-u"] "Update installed packages after syncing") - (purge-p ["-p" "--prune"] "Purge orphaned package repos & regraft them")) +(load! "packages") + + +;; +;;; Variables + +(defvar doom-after-sync-hook () + "Hooks run after 'doom sync' synchronizes the user's config with Doom.") + +(defvar doom-before-sync-hook () + "Hooks run before 'doom sync' synchronizes the user's config with Doom.") + + +;; +;;; Commands + +(defalias! (:before (sync s)) (:before build)) + +(defcli! ((sync s)) + ((noenvvar? ("-e") "Don't regenerate the envvar file") + (noelc? ("-c") "Don't recompile config") + (update? ("-u") "Update installed packages after syncing") + (purge? ("-p") "Purge orphaned package repos & regraft them")) "Synchronize your config with Doom Emacs. This is the equivalent of running autoremove, install, autoloads, then @@ -18,39 +38,36 @@ recompile. Run this whenever you: It will ensure that unneeded packages are removed, all needed packages are installed, autoloads files are up-to-date and no byte-compiled files have gone stale." - (run-hooks 'doom-sync-pre-hook) - (add-hook 'kill-emacs-hook #'doom--cli-abort-warning-h) + :benchmark t + (run-hooks 'doom-before-sync-hook) + (add-hook 'kill-emacs-hook #'doom-sync--abort-warning-h) (print! (start "Synchronizing your config with Doom Emacs...")) (unwind-protect (print-group! - (delete-file doom-autoloads-file) - (when (and (not no-envvar-p) + (when (and (not noenvvar?) (file-exists-p doom-env-file)) - (doom-cli-reload-env-file 'force)) - (doom-cli-packages-install) - (doom-cli-packages-build) - (when update-p - (doom-cli-packages-update)) - (doom-cli-packages-purge purge-p 'builds-p purge-p purge-p purge-p) - (run-hooks 'doom-sync-post-hook) + (doom-cli-call '("doom" "env"))) + (doom-packages-install) + (doom-packages-build) + (when update? + (doom-packages-update)) + (doom-packages-purge purge? 'builds-p purge? purge? purge?) + (run-hooks 'doom-after-sync-hook) (when (doom-autoloads-reload) - (print! (info "Restart Emacs or use 'M-x doom/reload' for changes to take effect"))) + (print! (item "Restart Emacs or use 'M-x doom/reload' for changes to take effect"))) t) - (remove-hook 'kill-emacs-hook #'doom--cli-abort-warning-h))) + (remove-hook 'kill-emacs-hook #'doom-sync--abort-warning-h))) - -;; -;;; DEPRECATED Commands - -(defcli! (refresh re) () - "Deprecated for 'doom sync'" - :hidden t - (user-error "'doom refresh' has been replaced with 'doom sync'. Use that instead")) +;; DEPRECATED Remove when v3.0 is released +(defobsolete! ((refresh re)) "doom sync" "v3.0.0") ;; ;;; Helpers -(defun doom--cli-abort-warning-h () - (terpri) - (print! (warn "Script was abruptly aborted! Run 'doom sync' to repair inconsistencies"))) +(defun doom-sync--abort-warning-h () + (print! (warn "Script was abruptly aborted, leaving Doom in an incomplete state!")) + (print! (item "Run 'doom sync' to repair it."))) + +(provide 'core-cli-sync) +;;; sync.el ends here diff --git a/core/cli/test.el b/core/cli/test.el index 1defcf063..ce4bd923c 100644 --- a/core/cli/test.el +++ b/core/cli/test.el @@ -1,16 +1,20 @@ ;;; core/cli/test.el -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: -(defun doom--emacs-binary () - (let ((emacs-binary-path (doom-path invocation-directory invocation-name)) - (runemacs-binary-path (if IS-WINDOWS (doom-path invocation-directory "runemacs.exe")))) - (if (and runemacs-binary-path (file-exists-p runemacs-binary-path)) - runemacs-binary-path - emacs-binary-path))) +;; +;;; Variables +;; None yet! + + +;; +;;; Commands (defcli! test (&rest targets) "Run Doom unit tests." - :bare t + :disable t + ;; FIXME Tests don't work; will be fixed in v3.1 (doom-initialize 'force 'noerror) (require 'ansi-color) (let (files read-files) @@ -39,13 +43,12 @@ (print! (start "Bootstrapping test environment, if necessary...")) (cl-destructuring-bind (status . output) (doom-exec-process - (doom--emacs-binary) + (doom-test--emacs-binary) "--batch" "--eval" (prin1-to-string `(progn - (setq user-emacs-directory ,doom-emacs-dir - doom-auto-accept t) + (setq user-emacs-directory ,doom-emacs-dir) (require 'core ,(locate-library "core")) (require 'core-cli) (doom-initialize 'force 'noerror) @@ -60,7 +63,7 @@ (if (doom-file-cookie-p file "if" t) (cl-destructuring-bind (_status . output) (apply #'doom-exec-process - (doom--emacs-binary) + (doom-test--emacs-binary) "--batch" "-l" (concat doom-core-dir "core.el") "-l" (concat doom-core-dir "test/helpers.el") @@ -70,7 +73,7 @@ "-f" "buttercup-run"))) (insert (replace-regexp-in-string ansi-color-control-seq-regexp "" output)) (push file read-files)) - (print! (info "Ignoring %s" (relpath file))))) + (print! (item "Ignoring %s" (relpath file))))) (let ((total 0) (total-failed 0) (i 0)) @@ -102,3 +105,16 @@ (print! (error "Ran %d tests, %d failed") total total-failed) (kill-emacs 1))) t))) + + +;; +;;; Helpers + +(defun doom-test--emacs-binary () + (let ((emacs-binary-path (doom-path invocation-directory invocation-name)) + (runemacs-binary-path (if IS-WINDOWS (doom-path invocation-directory "runemacs.exe")))) + (if (and runemacs-binary-path (file-exists-p runemacs-binary-path)) + runemacs-binary-path + emacs-binary-path))) + +;;; test.el ends here diff --git a/core/cli/upgrade.el b/core/cli/upgrade.el index deab424b2..b6080007d 100644 --- a/core/cli/upgrade.el +++ b/core/cli/upgrade.el @@ -1,8 +1,26 @@ ;;; core/cli/upgrade.el -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: -(defcli! (upgrade up) - ((force-p ["-f" "--force"] "Discard local changes to Doom and packages, and upgrade anyway") - (packages-only-p ["-p" "--packages"] "Only upgrade packages, not Doom")) +(load! "packages") + + +;; +;;; Variables + +(defvar doom-upgrade-url "https://github.com/doomemacs/doomemacs" + "The git repo url for Doom Emacs.") + +(defvar doom-upgrade-remote "_upgrade" + "The name to use as our staging remote.") + + +;; +;;; Commands + +(defcli! ((upgrade up)) + ((packages? ("-p" "--packages") "Only upgrade packages, not Doom") + &context context) "Updates Doom and packages. This requires that ~/.emacs.d is a git repo, and is the equivalent of the @@ -10,50 +28,27 @@ following shell commands: cd ~/.emacs.d git pull --rebase - bin/doom clean - bin/doom sync -u" - :bare t - (let ((doom-auto-discard force-p)) + doom clean + doom sync -u" + (let* ((force? (doom-cli-context-suppress-prompts-p context)) + (sync-cmd `("doom" "sync" "-u"))) (cond - (packages-only-p - (doom-cli-execute "sync" "-u") + (packages-only? + (doom-cli-call sync-cmd) (print! (success "Finished upgrading Doom Emacs"))) - ((doom-cli-upgrade doom-auto-accept doom-auto-discard) + ((doom-cli-upgrade force? force?) ;; Reload Doom's CLI & libraries, in case there were any upstream changes. ;; Major changes will still break, however - (print! (info "Reloading Doom Emacs")) - (throw 'exit (list "doom" "upgrade" "-p" (if force-p "-f")))) + (print! (item "Reloading Doom Emacs")) + (exit! "doom" "upgrade" "-p" (if force? "--force"))) ((print! "Doom is up-to-date!") - (doom-cli-execute "sync" "-u"))))) + (doom-cli-call sync-cmd))))) ;; -;;; library - -(defvar doom-repo-url "https://github.com/hlissner/doom-emacs" - "The git repo url for Doom Emacs.") -(defvar doom-repo-remote "_upgrade" - "The name to use as our staging remote.") - -(defun doom--working-tree-dirty-p (dir) - (cl-destructuring-bind (success . stdout) - (doom-call-process "git" "status" "--porcelain" "-uno") - (if (= 0 success) - (split-string stdout "\n" t) - (error "Failed to check working tree in %s" dir)))) - -(defun doom--get-straight-recipe () - (with-temp-buffer - (insert-file-contents (doom-path doom-core-dir "packages.el")) - (when (re-search-forward "(package! straight" nil t) - (goto-char (match-beginning 0)) - (let ((sexp (sexp-at-point))) - (plist-put sexp :recipe - (eval (plist-get sexp :recipe) - t)))))) - +;;; Helpers (defun doom-cli-upgrade (&optional auto-accept-p force-p) "Upgrade Doom to the latest version non-destructively." @@ -70,18 +65,19 @@ following shell commands: (cdr (doom-call-process "git" "name-rev" "--name-only" "HEAD")))) (target-remote (format "%s_%s" doom-repo-remote branch))) (unless branch - (error! (if (file-exists-p! ".git" doom-emacs-dir) - "Couldn't find Doom's .git directory. Was Doom cloned properly?" - "Couldn't detect what branch you're on. Is Doom detached?"))) + (error (if (file-exists-p! ".git" doom-emacs-dir) + "Couldn't find Doom's .git directory. Was Doom cloned properly?" + "Couldn't detect what branch you're on. Is Doom detached?"))) ;; We assume that a dirty .emacs.d is intentional and abort - (when-let (dirty (doom--working-tree-dirty-p default-directory)) + (when-let (dirty (doom-upgrade--working-tree-dirty-p default-directory)) (if (not force-p) - (user-error! "%s\n\n%s\n\n %s" - (format "Refusing to upgrade because %S has been modified." (path doom-emacs-dir)) - "Either stash/undo your changes or run 'doom upgrade -f' to discard local changes." - (string-join dirty "\n")) - (print! (info "You have local modifications in Doom's source. Discarding them...")) + (user-error "%s\n\n%s\n\n %s" + (format "Refusing to upgrade because %S has been modified." + (abbreviate-file-name doom-emacs-dir)) + "Either stash/undo your changes or run 'doom upgrade -f' to discard local changes." + (string-join dirty "\n")) + (print! (item "You have local modifications in Doom's source. Discarding them...")) (doom-call-process "git" "reset" "--hard" (format "origin/%s" branch)) (doom-call-process "git" "clean" "-ffd"))) @@ -104,7 +100,7 @@ following shell commands: (print! (success "Doom is already up-to-date!")) nil) - ((print! (info "A new version of Doom Emacs is available!\n\n Old revision: %s (%s)\n New revision: %s (%s)\n" + ((print! (item "A new version of Doom Emacs is available!\n\n Old revision: %s (%s)\n New revision: %s (%s)\n" (substring this-rev 0 10) (cdr (doom-call-process "git" "log" "-1" "--format=%cr" "HEAD")) (substring new-rev 0 10) @@ -117,7 +113,7 @@ following shell commands: (print! "Link to diff: %s" diff-url) (when (and (not auto-accept-p) (y-or-n-p "View the comparison diff in your browser?")) - (print! (info "Opened github in your browser.")) + (print! (item "Opened github in your browser.")) (browse-url diff-url))) (if (not (or auto-accept-p @@ -126,24 +122,43 @@ following shell commands: (print! (start "Upgrading Doom Emacs...")) (print-group! (doom-clean-byte-compiled-files) - (let ((straight-recipe (doom--get-straight-recipe))) + (let ((straight-recipe (doom-upgrade--get-straight-recipe))) (or (and (zerop (car (doom-call-process "git" "reset" "--hard" target-remote))) (equal (cdr (doom-call-process "git" "rev-parse" "HEAD")) new-rev)) (error "Failed to check out %s" (substring new-rev 0 10))) ;; HACK It's messy to use straight to upgrade straight, due - ;; to the potential for backwards incompatibility, so - ;; we staticly check if Doom's `package!' declaration - ;; for straight has changed. If it has, delete - ;; straight so 'doom upgrade's second stage will - ;; install the new version for us. + ;; to the potential for backwards incompatibility, so we + ;; staticly check if Doom's `package!' declaration for + ;; straight has changed. If it has, delete straight so + ;; 'doom upgrade's second stage will install the new + ;; version for us. ;; - ;; Clumsy, but a better solution is in the works. - (unless (equal straight-recipe (doom--get-straight-recipe)) - (print! (info "Preparing straight for an update")) + ;; Clumsy, but a better solution is in the works. + (unless (equal straight-recipe (doom-upgrade--get-straight-recipe)) + (print! (item "Preparing straight for an update")) (delete-directory (doom-path straight-base-dir "straight/repos/straight.el") 'recursive))) - (print! (info "%s") (cdr result)) + (print! (item "%s") (cdr result)) t)))))) (ignore-errors (doom-call-process "git" "branch" "-D" target-remote) (doom-call-process "git" "remote" "remove" doom-repo-remote)))))) + +(defun doom-upgrade--working-tree-dirty-p (dir) + (cl-destructuring-bind (success . stdout) + (doom-call-process "git" "status" "--porcelain" "-uno") + (if (= 0 success) + (split-string stdout "\n" t) + (error "Failed to check working tree in %s" dir)))) + +(defun doom-upgrade--get-straight-recipe () + (with-temp-buffer + (insert-file-contents (doom-path doom-core-dir "packages.el")) + (when (re-search-forward "(package! straight" nil t) + (goto-char (match-beginning 0)) + (let ((sexp (sexp-at-point))) + (plist-put sexp :recipe + (eval (plist-get sexp :recipe) + t)))))) + +;;; upgrade.el ends here diff --git a/core/core-cli-lib.el b/core/core-cli-lib.el new file mode 100644 index 000000000..2feabb93e --- /dev/null +++ b/core/core-cli-lib.el @@ -0,0 +1,1724 @@ +;;; core/core-cli-lib.el --- API+DSL for Doom's CLI framework -*- lexical-binding: t; no-byte-compile: t; -*- +;;; Commentary: +;;; Code: + +;; Appease byte-compiler-sama +(eval-when-compile + ;; ...but prevent recursive or unwanted loads + (unless (or load-in-progress (not noninteractive)) + (require 'core-cli))) + + +;; +;;; Variables + +(defvar doom-cli-load-path + (ignore-errors (split-string (getenv "DOOMPATH") path-separator)) + "A list of paths to search for autoloaded CLIs on.") + +(defvar doom-cli-argument-types + '(&args + &cli + &context + &flags + &multiple + &optional + &rest + &required + &input + &whole) + "A list of auxiliary keywords allowed in `defcli!'s arglist. + +See `defcli!' for documentation on them.") + +(defvar doom-cli-option-types + '((&flag . &flags) + (&multi . &multiple)) + "An alist of auxiliary keywords permitted in option specs in `defcli!'. + +They serve as shorter, inline aliases for `doom-cli-argument-types'. + +See `defcli!' for documentation on them.") + +(defvar doom-cli-option-generators + '((&flags . doom-cli--make-option-flag) + (&multiple . doom-cli--make-option-multi) + (&required . doom-cli--make-option-generic) + (&optional . doom-cli--make-option-generic)) + "An alist of `doom-cli-option' factories for argument types. + +Types that + +See argument types in `doom-cli-argument-types', and `defcli!' for usage.") + +(defvar doom-cli-option-arg-types + `((dir :test file-directory-p + :read doom-path + :error "Directory does not exist" + :zshcomp "_dirs") + (file :test file-exists-p + :read doom-path + :error "File does not exist" + :zshcomp "_files") + (path :read expand-file-name :zshcomp "_files") + (form :read read) + (regexp :test ,(doom-rpartial #'string-match-p "")) + (int :test "^[0-9]+$" + :read string-to-number + :error "Not an integer") + (num :test "^[0-9]+\\(\\.[0-9]+\\)?$" + :read string-to-number + :error "Not a valid number or float") + (float :test "^[0-9]+\\(\\.[0-9]+\\)$" + :read string-to-number + :error "Not a float") + (bool :test "^y\\(?:es\\)?\\|no?\\|on\\|off\\|t\\(?:rue\\)?\\|false\\|[01]\\|$" + :read ,(lambda (x) + (pcase x + ((or "y" "yes" "t" "true" "1" "on") :yes) + ((or "n" "no" "nil" "false" "0" "off") :no))) + :error "Not a valid boolean, should be blank or one of: yes, no, y, n, true, false, on, off" + :zshcomp "(y n yes no true false on off 1 0)") + ;; TODO Implement these implicit types + ;; (date ...) + ;; (time ...) + ;; (duration ...) + ;; (size ...) + ) + "A list of implicit option argument datatypes and their rules. + +Recognizies the following properies: + + :test FN + Predicate function to determine if a value is valid. + :read FN + A transformer that converts the string argument to a desired format. + :error STR + The message to display if a value fails :test.") + +(defvar doom-cli-exit-commands + '(;; (:editor . doom-cli--exit-editor) + ;; (:emacs . doom-cli--exit-emacs) + (:pager . doom-cli--exit-pager) + (:pager? . doom-cli--exit-pager-maybe) + (:restart . doom-cli--exit-restart)) + "An alist of commands that `doom-cli--exit' recognizes.") + +(defvar doom-cli-pager (getenv "DOOMPAGER") + "The PAGER command to use. + +If nil, falls back to less.") + +(defvar doom-cli-pager-ratio 1.0 + "If output exceeds TTY height times this ratio, the pager is invoked. + +Only applies if (exit! :pager) or (exit! :pager?) are called.") + +(defvar doom-cli-log-file-format (expand-file-name "logs/cli.%s.%s.%s" doom-local-dir) + "Where to write any output/log file to. + +Must have two arguments, one for session id and the other for log type.") + +(defvar doom-cli-log-retain 12 + "Number of each log type to retain.") + +(defvar doom-cli-backtrace-depth 12 + "How many frames of the backtrace to display in stdout.") + +(defvar doom-cli-straight-error-lines 16 + "How many lines of straight.el errors to display in stdout.") + +(defvar doom-cli-benchmark-threshold 5 + "How much execution time (in seconds) before benchmark is shown. + +If set to nil, only display benchmark if a CLI explicitly requested with a +non-nil :benchmark property.") + +(defvar doom-cli--context nil) +(defvar doom-cli--exit-code 255) +(defvar doom-cli--plist nil) +(defvar doom-cli--table (make-hash-table :test 'equal)) + + +;; +;;; Hooks + +(defvar doom-cli-create-context-functions () + "A hook executed once a new context has been generated. + +Called by `doom-cli-context-parse' and `doom-cli-context-restore', once a +`doom-cli-context' is fully populated and ready to be executed (but before it +has). + +Hooks are run with one argument: the newly created context.") + +(defvar doom-cli-before-run-functions () + "Hooks run before `doom-cli-run' executes the command. + +Runs with a single argument: the active context (a `doom-cli-context' struct).") + +(defvar doom-cli-after-run-functions () + "Hooks run after `doom-cli-run' has executed the command. + +Runs with two arguments: the active context (a `doom-cli-context' struct) and +the return value of the executed CLI.") + + +;; +;;; Errors + +(define-error 'doom-cli-error "There was an unexpected error" 'doom-error) +(define-error 'doom-cli-definition-error "Invalid CLI definition" 'doom-cli-error) +(define-error 'doom-cli-autoload-error "Failed to autoload deferred command" 'doom-cli-error) +(define-error 'doom-cli-invalid-prefix-error "Prefix has no defined commands" 'doom-cli-error) +(define-error 'doom-cli-command-not-found-error "Could not find that command" 'doom-cli-error) +(define-error 'doom-cli-wrong-number-of-arguments-error "Wrong number of CLI arguments" 'doom-cli-error) +(define-error 'doom-cli-unrecognized-option-error "Not a recognized option" 'doom-cli-error) +(define-error 'doom-cli-invalid-option-error "Invalid option value" 'doom-cli-error) +(define-error 'doom-cli-deprecated-error "Command is deprecated" 'doom-cli-error) + + +;; +;;; `doom-cli' + +(cl-defstruct doom-cli + "An executable CLI command." + (command nil :read-only t) + type + docs + autoload + alias + options + arguments + plist + fn) + +(defun doom-cli-execute (cli bindings) + "Execute CLI with BINDINGS (an alist). + +BINDINGS is an alist of (SYMBOL . VALUE) to bind lexically during CLI's +execution. Can be generated from a `doom-cli-context' with +`doom-cli--bindings'." + (let ((plist (doom-cli-plist cli))) + (doom-log "doom-cli-execute: %s %s" (doom-cli-key cli) plist) + (when (plist-get plist :stub) + (user-error "Command not implemented yet")) + (when (plist-get plist :obsolete) + (print! (warn "Command is obsolete and may be removed soon")))) + (funcall (doom-cli-fn cli) cli bindings)) + +(defun doom-cli-key (cli) + "Return CLI's (type . command), used as a table key or unique identifier." + (let ((command (doom-cli-command cli))) + (if-let (type (doom-cli-type cli)) + (cons type command) + command))) + +(defun doom-cli-command-normalize (command &optional plist) + "Ensure that COMMAND is properly formatted. + +This means that all non-keywords are strings, any prefixes provided by PLIST are +prepended, and the keyword is in front." + (let* ((command (doom-enlist command)) + (prefix (plist-get plist :prefix)) + (prefix (if prefix (doom-cli-command-normalize + prefix (append `(:prefix nil) plist)))) + (command (append prefix command)) + (type (cl-find-if #'keywordp (remq :root command) :from-end t)) + (command (seq-subseq + command (or (cl-position :root command :from-end t) + 0)))) + (when (or command prefix) + (cl-loop with map = (fn!! (if (or (stringp %) (keywordp %)) % (prin1-to-string %))) + for c in (delq nil (cons type (seq-remove #'keywordp command))) + if (listp c) + collect (mapcar map c) + else collect (funcall map c))))) + +(defun doom-cli-command-string (command) + "Return a joined string representation of normalized COMMAND. + +COMMAND should either be a command list (e.g. '(doom foo bar)) or a `doom-cli' +struct." + (mapconcat (doom-partial #'format "%s") + (doom-cli--command command) + " ")) + +(defun doom-cli-get (command &optional noresolve? noload?) + "Return CLI at COMMAND. + +Will autoload COMMAND if it was deferred with `defautoload!'. + +If NORESOLVE?, don't follow aliases." + (when-let* ((command (doom-cli--command command)) + (cli (gethash command doom-cli--table)) + (cli (if noload? cli (doom-cli-load cli)))) + (if noresolve? + cli + (let (path) + (while (setq path (ignore-errors (doom-cli-alias cli))) + (setq cli (doom-cli-get path t noload?))) + (unless cli + (signal 'doom-cli-command-not-found-error (or path command))) + cli)))) + +(defun doom-cli-find (command &optional norecursive) + "Find all CLIs assocated with COMMAND, excluding partials if NORECURSIVE. + +COMMAND can be a command path (list of strings), a `doom-cli' struct, or a +`doom-cli-context' struct. + +Returned in the order they will execute. Includes pseudo CLIs." + (let* ((command (doom-cli--command command)) + (pseudo? (keywordp (car-safe command))) + (paths (doom-cli--command-expand command t)) + results) + (unless pseudo? + (dolist (path paths) + (push (cons :before path) results))) + (push command results) + (unless pseudo? + (dolist (path (reverse paths)) + (push (cons :after path) results))) + (setq results (delq nil (mapcar #'doom-cli-get results)) + results (nreverse (delete-dups results))))) + +(defun doom-cli-prop (cli prop &optional null-value) + "Returns a PROPerty of CLI's plist, or NULL-VALUE if it doesn't exist." + (let ((plist (doom-cli-plist cli))) + (if (plist-member plist prop) + (plist-get plist prop) + null-value))) + +(cl-defun doom-cli-subcommands (command &optional (depth 9999) &key tree? all? predicate?) + "Return a list of subcommands, DEPTH levels deep, below COMMAND. + + If DEPTH is non-nil, list *all* subcommands, recursively. Otherwise it expects +an integer. + If TREE?, return commands in a tree structure. + If ALL?, include hidden commands (like aliases)." + (when (or (null depth) (> depth 0)) + (catch :predicate + (let* ((command (doom-cli--command command t)) + (prefixlen (length command)) + results) + (dolist (cli (hash-table-values doom-cli--table)) + (let ((clicmd (doom-cli-command cli))) + (when (and (not (doom-cli-type cli)) + (= (length clicmd) (1+ prefixlen)) + (equal command (seq-take clicmd prefixlen)) + (or all? (not (doom-cli-prop cli :hide)))) + (when predicate? + (throw :predicate t)) + (let* ((car (if tree? (car (last clicmd)) clicmd)) + (cdr (doom-cli-subcommands + clicmd (if depth (1- depth)) + :tree? tree? + :all? all?))) + (if tree? + (push (if cdr (cons car cdr) car) results) + (cl-callf nconc results (cons car cdr))))))) + (if tree? + (nreverse results) + results))))) + +(defun doom-cli-aliases (cli) + "Return all known `doom-cli's that are aliased to CLI. + +This cannot see autoloaded CLIs. Use `doom-cli-load' or `doom-cli-load-all' +to reach them." + (cl-loop for rcli in (hash-table-values doom-cli--table) + if (equal (doom-cli-alias rcli) (doom-cli-key cli)) + collect rcli)) + +(defun doom-cli-short-docs (cli) + "Return the first line of CLI's documentation. + +Return nil if CLI (a `doom-cli') has no explicit documentation." + (ignore-errors (cdr (assoc "SUMMARY" (doom-cli-docs cli))))) + +(defun doom-cli--bindings (cli context &optional seen) + "Return a CLI with a value alist in a cons cell." + (let* ((optspec (doom-cli-options cli)) + (argspec (doom-cli-arguments cli)) + alist) + ;; Ensure all symbols are defined + (dolist (opt optspec) + (setf (alist-get (doom-cli-option-symbol opt) alist) + (doom-cli-option-default opt))) + (dolist (syms argspec) + (dolist (sym (cdr syms)) + (setf (alist-get sym alist) nil))) + ;; Populate options + (let ((options (doom-cli-context-options context))) + (dolist (opt optspec) + (when-let (option (cl-loop for flag in (doom-cli-option-switches opt) + if (cdr (assoc flag options)) + return (cons flag it))) + (unless (member (car option) seen) + (setf (alist-get (doom-cli-option-symbol opt) alist) + (cdr option)) + (push (car option) seen))))) + ;; Populate arguments + (let* ((arglist (doom-cli-context-arguments context)) + (rest (copy-sequence (alist-get (doom-cli-command cli) arglist nil nil #'equal))) + (args (copy-sequence (alist-get t arglist))) + (argc (length args)) + (required (alist-get '&required argspec)) + (optional (alist-get '&optional argspec)) + (spec (append required optional)) + (min (length required)) + (max (if (or (assq '&args argspec) + (assq '&rest argspec)) + most-positive-fixnum + (length spec)))) + (when (or (< argc min) + (> argc max)) + (signal 'doom-cli-wrong-number-of-arguments-error + (list (doom-cli--command context) nil args min max))) + (dolist (sym spec) + (setf (alist-get sym alist) (if args (pop args)))) + (dolist (type `((&args . ,args) + (&cli . ,cli) + (&context . ,context) + (&input + . ,(if (doom-cli-context-pipe-p context :in t) + (with-current-buffer (doom-cli-context-stdin context) + (buffer-string)))) + (&rest . ,rest) + (&whole . ,(doom-cli-context-whole context)))) + (when-let (var (car (alist-get (car type) argspec))) + (setf (alist-get var alist) (cdr type))))) + alist)) + +(defun doom-cli--command (target &optional notype?) + "Fetch the normalized command from TARGET. + +If NOTYPE? is non-nil, omit any leading keywords from the command. + +TARGET can be a `doom-cli', `doom-cli-context', or a command list." + (cond ((doom-cli-p target) + (if notype? + (doom-cli-command target) + (doom-cli-key target))) + ((doom-cli-context-p target) + (doom-cli-context-command target)) + ((and target (not (listp target))) + (signal 'wrong-type-argument + (list '(doom-cli-p doom-cli-context-p listp) target))) + ((let ((target (doom-cli-command-normalize target))) + (if (and notype? (keywordp (car target))) + (cdr target) + target))))) + +(defun doom-cli--command-expand (commandspec &optional recursive?) + "Expand COMMANDSPEC into a list of commands. + +If RECURSIVE, includes breadcrumbs leading up to COMMANDSPEC." + (funcall (if recursive? + #'identity + (fn!! (cl-loop with cmdlen = (length (car %)) + for command in % + while (= (length command) cmdlen) + collect command))) + (seq-reduce (lambda (init next) + (nconc (cl-loop with firstlen = (length (car init)) + for seg in (doom-enlist next) + nconc + (cl-loop for command in init + while (= (length command) firstlen) + collect (append command (list seg)))) + init)) + (cdr commandspec) + `(,@(mapcar #'list (doom-enlist (car commandspec))))))) + +(defun doom-cli--parse-docs (docs) + (when (and (stringp docs) + (not (equal docs "TODO"))) + (let ((re "^\\([A-Z0-9 _-]+\\):\n") sections) + (with-temp-buffer + (save-excursion + (insert "__DOOMDOCS__:\n") + (insert docs)) + (while (re-search-forward re nil t) + (push (cons (match-string 1) + (let ((buffer (current-buffer)) + (beg (match-end 0)) + (end (save-excursion + (if (re-search-forward re nil t) + (1- (match-beginning 0)) + (point-max))))) + (with-temp-buffer + (insert-buffer-substring buffer beg end) + (goto-char (point-min)) + (indent-rigidly (point-min) (point-max) (- (skip-chars-forward " "))) + (string-trim-right (buffer-string))))) + sections))) + (let ((lines (split-string (cdr (assoc "__DOOMDOCS__" sections)) "\n")) + (sections (assoc-delete-all "__DOOMDOCS__" sections))) + `(("SUMMARY" . ,(car lines)) + ("MAIN" . ,(string-trim (string-join (cdr lines) "\n"))) + ,@(nreverse sections)))))) + + +;; +;;; `doom-cli-option' + +(cl-defstruct doom-cli-option + "A switch specification dictating the characteristics of a recognized option." + (symbol nil :read-only t) + docs + multiple-p + flag-p + switches + arguments + default) + +(defun doom-cli-option-validate (option &rest values) + "Test if OPTION will accept VALUES, and conforms them if necessary. + +OPTION is a `doom-cli-option' struct. VALUES can be any arbitrary values. +Returns VALUES once mapped through their respective reader (as dictated by +`doom-cli-option-arg-types'). + +Throws `doom-cli-invalid-option-error' for illegal values." + (let ((args (doom-cli-option-arguments option)) + (values (copy-sequence values))) + (dotimes (i (length args) values) + (let ((value (nth i values)) + (types (ensure-list (nth i args))) + errors) + (catch 'done + (dolist (type (ensure-list (nth i args))) + (pcase-let + (((map :test :read :error) + (if (or (symbolp type) + (and (stringp type) + (string-match-p "^[A-Z0-9-_]+$" type))) + (cdr (assq (if (symbolp type) type (intern type)) + doom-cli-option-arg-types)) + (list 'str :test #'stringp)))) + (condition-case-unless-debug e + (or (and (or (null test) + (if (stringp test) + (and (string-match-p test value) t) + (funcall test value))) + (or (null read) + (setf (nth i values) (funcall read value))) + (throw 'done t)) + (push error errors)) + ((invalid-regexp invalid-read-syntax) + (push (error-message-string e) errors))))) + (signal 'doom-cli-invalid-option-error + (list types option value errors))))))) + +(defun doom-cli--read-option-switches (optspec) + (delq + nil (cl-loop for spec in optspec + if (and (stringp spec) + (string-match-p "^-\\(?:-[a-zA-Z0-9]\\|[^-]$\\)" spec)) + collect spec))) + +(defun doom-cli--read-option-args (argspec) + (delq + nil (cl-loop for spec in argspec + if (or (and (stringp spec) + (not (string-match-p "^-\\(?:-[a-zA-Z0-9]\\|[^-]$\\)" spec))) + (keywordp spec)) + collect spec + else if (symbolp spec) + collect spec))) + +(defun doom-cli--make-option-generic (symbol spec &optional docs) + (make-doom-cli-option + :symbol symbol + :docs docs + :switches (doom-cli--read-option-switches spec) + :arguments (doom-cli--read-option-args spec))) + +(defun doom-cli--make-option-flag (symbol spec &optional docs) + (let ((switches (doom-cli--read-option-switches spec)) + (args (doom-cli--read-option-args spec))) + (when (and args + (not (or (memq :yes args) + (memq :no args)))) + (signal 'doom-cli-definition-error + (cons "Argument type %s cannot accept arguments for: %s" + '&flag (mapconcat #'symbol-name spec ", ")))) + (make-doom-cli-option + :symbol symbol + :docs docs + :flag-p t + :switches switches + :default (car args)))) + +(defun doom-cli--make-option-multi (symbol spec &optional docs) + (make-doom-cli-option + :symbol symbol + :docs docs + :multiple-p t + :switches (doom-cli--read-option-switches spec) + :arguments (doom-cli--read-option-args spec))) + + +;; +;;; `doom-cli-context' + +(cl-defstruct doom-cli-context + "A CLI context, containing all state pertinent to the current session." + (init-time before-init-time) ; When this context was created + ;; A session-specific ID of the current context (defaults to number + (pid (if-let (pid (getenv "__DOOMPID")) + (string-to-number pid) + (emacs-pid))) + ;; Number of Emacs processes this context has been processed through + (step (if-let (step (getenv "__DOOMSTEP")) + (string-to-number step) + -1)) + ;; The geometry of the terminal window. + (geometry (when-let* ((geom (getenv "__DOOMGEOM")) + (geom (split-string geom "\n"))) + (cons (string-to-number (car geom)) + (string-to-number (cadr geom))))) + ;; Whether the script is being piped into or out of + (pipes (cl-loop for (env . scope) in `((,(getenv "__DOOMGPIPE") . global) + (,(getenv "__DOOMPIPE") . local)) + if (stringp env) + for pipes = (string-to-list env) + nconc `(,@(if (memq ?0 pipes) `((:in . ,scope))) + ,@(if (memq ?1 pipes) `((:out . ,scope))))) + :skip t) + ;; If non-nil, suppress prompts and auto-accept their consequences. + (suppress-prompts-p (if (getenv "__DOOMFORCE") t)) + (prefix "@") ; The basename of the script creating this context + meta-p ; Whether or not this is a help/meta request + error ; + command ; The full command that led to this context + path ; Breadcrumb list of resolved commands so far + whole ; Unfiltered and unprocessed list of arguments + options ; An alist of (flags . value) + arguments ; An alist of non-subcommand arguments, by command + (stdin (generate-new-buffer " *doom-cli stdin*") :type buffer) ; buffer containing anything piped into this session + (stdout (generate-new-buffer " *doom-cli stdout*") :type buffer) ; buffer containing user-visible output + (stderr (generate-new-buffer " *doom-cli stderr*") :type buffer) ; buffer containing all output, including debug output + ;; An alist of persistent and arbitrary elisp state + (state nil :type alist)) + +(defun doom-cli-context-execute (context) + "Execute a given CONTEXT. + +Use `doom-cli-context-parse' or `doom-cli-context-restore' to produce a valid, +executable context." + (let* ((command (doom-cli--command context)) + (cli (doom-cli-get command)) + (prefix (doom-cli-context-prefix context))) + (doom-log "doom-cli-context-execute: %s %s" command context) + (cond ((null (or command (doom-cli-get (list prefix) t))) + (signal 'doom-cli-invalid-prefix-error (list prefix))) + + (doom-cli--dump (doom-cli--dump (doom-cli-find command))) + + ((doom-cli-context-meta-p context) + (pcase (doom-cli-context-meta-p context) + ("--version" + (doom-cli-call `(:version ,@(cdr command)) context) + t) + ((or "-?" "--help") + (doom-cli-call `(:help ,@(cdr command)) context) + t) + (_ (error "In meta mode with no destination!")))) + + ((not (and cli (doom-cli-fn cli))) + (signal 'doom-cli-command-not-found-error + (append command (alist-get t (doom-cli-context-arguments context))))) + + ((let ((seen '(t))) + (dolist (cli (doom-cli-find command (doom-cli-type cli))) + (doom-cli-execute cli (doom-cli--bindings cli context seen))) + context))))) + +(defun doom-cli-context-restore (file context) + "Restore the last restarted context from FILE into CONTEXT." + (when (and (stringp file) + (file-exists-p file)) + (when-let (old-context (with-temp-buffer + (insert-file-contents file) + (read (current-buffer)))) + (unless (doom-cli-context-p old-context) + (error "An invalid context was restored from file: %s" file)) + (unless (equal (doom-cli-context-prefix context) + (doom-cli-context-prefix old-context)) + (error "Restored context belongs to another script: %s" + (doom-cli-context-prefix old-context))) + (pcase-dolist (`(,slot ,_ . ,plist) + (cdr (cl-struct-slot-info 'doom-cli-context))) + (unless (plist-get plist :skip) + (let* ((idx (cl-struct-slot-offset 'doom-cli-context slot)) + (old-value (aref old-context idx))) + (aset context idx + (pcase (plist-get plist :type) + (`alist + (dolist (entry old-value (aref context idx)) + (setf (alist-get (car entry) (aref context idx)) (cdr entry)))) + (`buffer + (with-current-buffer (aref context idx) + (insert old-value) + (current-buffer))) + (_ old-value)))))) + (run-hook-with-args 'doom-cli-create-context-functions context) + (delete-file file) + (doom-log "Restored context: %s" (doom-cli-context-pid context)) + context))) + +(defun doom-cli-context-parse (args context) + "Parse ARGS and update CONTEXT to reflect it." + (let* ((case-fold-search t) + (args (delq nil (copy-sequence args))) + (arguments) + rest? + arg) + (while args + (setq arg (pop args)) + (save-match-data + (cond + ((equal arg "--") + (doom-log "Found arg separator" arg) + (setq arguments (cdr args) + args nil)) + + ((and (stringp arg) + (string-match "^\\(-\\([^-]\\{2,\\}\\)\\)" arg)) + (let ((chars (split-string (match-string 2 arg) "" t))) + (dolist (ch (nreverse chars)) + (push (concat "-" ch) args)))) + + ((and (stringp arg) + (or (string-match "^\\(--\\w[a-z0-9-_]+\\)\\(?:=\\(.*\\)\\)?$" arg) + (string-match "^\\(-[^-]\\)$" arg))) + (doom-log "Found switch: %s" arg) + (catch :skip + (let* ((fullflag (match-string 1 arg)) + (normflag (if (string-prefix-p "--no-" fullflag) + (concat "--" (substring fullflag 5)) + fullflag)) + (option (or (doom-cli-context-find-option context normflag) + (when (member fullflag '("-?" "--help" "--version")) + (doom-log "Found help switch: %s" arg) + (setf (doom-cli-context-meta-p context) fullflag) + (throw :skip t)) + (when rest? + (push arg arguments) + (throw :skip t)) + (signal 'doom-cli-unrecognized-option-error + (list fullflag)))) + (explicit-arg (match-string 2 arg)) + (argsleft (+ (length args) (if explicit-arg 1 0))) + (arity (length (doom-cli-option-arguments option))) + (key (if (doom-cli-option-multiple-p option) + (car (doom-cli-option-switches option)) + normflag))) + (doom-cli-context-put + context key + (let ((value (seq-take args arity))) + (when explicit-arg + (push explicit-arg value)) + (when (/= (length value) arity) + (signal 'doom-cli-wrong-number-of-arguments-error + (list (doom-cli--command context) + fullflag value arity arity))) + (setq args (seq-drop args arity) + value (apply #'doom-cli-option-validate option value)) + (cond ((doom-cli-option-flag-p option) + (if (string-prefix-p "--no-" fullflag) :no :yes)) + ((doom-cli-option-multiple-p option) + (append (doom-cli-context-get context key) + (if (doom-cli-option-arguments option) + (cl-loop for v in value + collect (cons fullflag v)) + (list fullflag)))) + ((= arity 1) (car value)) + ((> arity 1) value) + (fullflag))))))) + + ((when-let* + (((null arguments)) + (command (append (doom-cli--command context) (list arg))) + (cli (doom-cli-get command)) + (key (doom-cli-key cli))) + (doom-log "Found command: %s" command) + (unless (equal command key) + (doom-log "Laid breadcrumb: %s" command) + (push command (doom-cli-context-path context))) + (setf (doom-cli-context-command context) key + (map-elt (doom-cli-context-arguments context) + (doom-cli-command cli)) + (copy-sequence args)) + (dolist (cli (doom-cli-find key)) + (dolist (option (doom-cli-options cli)) + (dolist (switch (doom-cli-option-switches option)) + (unless (assoc switch (doom-cli-context-options context)) + (setf (map-elt (doom-cli-context-options context) switch) + nil))))) + (when (and (doom-cli-fn cli) + (alist-get '&rest (doom-cli-arguments cli))) + (setq rest? t)) + t)) + + ((push arg arguments) + (doom-log "Found argument: %s" arg))))) + + (setf (alist-get t (doom-cli-context-arguments context)) + (append (alist-get t (doom-cli-context-arguments context)) + (nreverse arguments))) + (run-hook-with-args 'doom-cli-create-context-functions context) + context)) + +(defun doom-cli-context-get (context key &optional null-value) + "Fetch KEY from CONTEXT's options or state. + +Context objects are essentially persistent storage, and may contain arbitrary +state tied to switches (\"--foo\" or \"-x\") or arbitrary symbols (state). + +If KEY is a string, fetch KEY from context's OPTIONS (by switch). +If KEY is a symbol, fetch KEY from context's STATE. +Return NULL-VALUE if KEY does not exist." + (if-let (value + (if (stringp key) + (assoc key (doom-cli-context-options context)) + (assq key (doom-cli-context-state context)))) + (cdr value) + null-value)) + +(defun doom-cli-context-put (context key val) + "Set KEY in CONTEXT's options or state to VAL. + +Context objects contain persistent storage, and may contain arbitrary state tied +to switches (\"--foo\" or \"-x\") or arbitrary symbols (state). Use this to +register data into CONTEXT. + +If KEY is a string, set the value of a switch named KEY to VAL. +If KEY is a symbol, set the value of the context's STATE to VAL." + (setf (alist-get + key (if (stringp key) + (doom-cli-context-options context) + (doom-cli-context-state context)) + nil nil #'equal) + val)) + +(defun doom-cli-context-find-option (context switch) + "Return a `doom-cli-option' belonging to SWITCH in CONTEXT, if available. + +Returns nil if SWITCH isn't a valid option in CONTEXT or none of the associated +`doom-cli's have a `doom-cli-option' associated with SWITCH." + (when (assoc switch (doom-cli-context-options context)) + (cl-loop with command = (doom-cli-context-command context) + for cli in (doom-cli-find command) + if (seq-find (lambda (opt) + (let ((switches (doom-cli-option-switches opt))) + (or (member switch switches) + (and (doom-cli-option-flag-p opt) + (string-prefix-p "--no-" switch))))) + (doom-cli-options cli)) + return it))) + +(defun doom-cli-context-width (context) + "Return the width (in character units) of CONTEXT's original terminal." + (or (car (doom-cli-context-geometry context)) + 80)) + +(defun doom-cli-context-height (context) + "Return the height (in character units) of CONTEXT's original terminal." + (or (cdr (doom-cli-context-geometry context)) + 40)) + +(defun doom-cli-context-pipe-p (context type &optional global?) + "Return non-nil if TYPE is an active pipe in the local CONTEXT. + +TYPE can be one of `:in' (receiving input on stdin) or `:out' (output is piped +to another process), or any of `local-in', `local-out', `global-in', or +`global-out'. + +If GLOBAL? is non-nil, if TYPE is `:in' or `:out', the global context (the pipes +active in the super-session, rather than the local Emacs instance) will be +considered as well." + (let ((pipes (doom-cli-context-pipes context))) + (and (if global? + (assq type pipes) + (member (cons type 'local) pipes)) + t))) + +(defun doom-cli-context-sid (context &optional nodate?) + "Return a unique session identifier for CONTEXT." + (if nodate? + (doom-cli-context-pid context) + (format (format-time-string + "%y%m%d%H%M%S.%%s" (doom-cli-context-init-time context)) + (doom-cli-context-pid context)))) + + +;; +;;; Output management + +(defun doom-cli-debugger (type data &optional context) + "Print a more presentable backtrace to terminal and write it to file." + ;; HACK Works around a heuristic in eval.c for detecting errors in the + ;; debugger, which executes this handler again on subsequent calls. Taken + ;; from `ert--run-test-debugger'. + (cl-incf num-nonmacro-input-events) + (let* ((inhibit-read-only nil) + (inhibit-message nil) + (inhibit-redisplay nil) + (inhibit-trace t) + (executing-kbd-macro nil) + (load-read-function #'read) + (backtrace (doom-backtrace)) + (context (or context (make-doom-cli-context))) + (straight-error + (and (bound-and-true-p straight-process-buffer) + (stringp data) + (string-match-p (regexp-quote straight-process-buffer) data) + (with-current-buffer (straight--process-buffer) + (split-string (buffer-string) "\n" t)))) + (error-file (doom-cli--output-file 'error context))) + (cond + (straight-error + (print! (error "The package manager threw an error")) + (print! (error "Last %d lines of straight's error log:") + doom-cli-straight-error-lines) + (print-group! + (print! + "%s" (string-join + (seq-subseq straight-error + (max 0 (- (length straight-error) + doom-cli-straight-error-lines)) + (length straight-error)) + "\n"))) + (print! (warn "Wrote extended straight log to %s") + (path (let ((coding-system-for-write 'utf-8-auto)) + (with-temp-file error-file + (insert-buffer-substring (straight--process-buffer))) + (set-file-modes error-file #o600) + error-file)))) + ((eq type 'error) + (let* ((generic? (eq (car data) 'error)) + (doom-cli-backtrace-depth doom-cli-backtrace-depth) + (print-escape-newlines t)) + (if (doom-cli-context-p context) + (print! (error "There was an unexpected runtime error")) + (print! (bold (error "There was a fatal initialization error")))) + (print-group! + (print! "%s %s" (bold "Message:") + (if generic? + (error-message-string data) + (get (car data) 'error-message))) + (unless generic? + (print! "%s %S" (bold "Details:") (cdr data))) + (when backtrace + (print! (bold "Backtrace:")) + (print-group! + (dolist (frame (seq-take backtrace doom-cli-backtrace-depth)) + (print! "%s" (truncate (prin1-to-string + (cons (backtrace-frame-fun frame) + (backtrace-frame-args frame))) + (- (doom-cli-context-width context) + doom-print-indent + 1) + "...")))) + (when-let (backtrace-file (doom-backtrace-write-to-file backtrace error-file)) + (print! (warn "Wrote extended backtrace to %s") + (path backtrace-file)))))))) + (exit! 255))) + +(defun doom-cli--output-file (type context) + "Return a log file path for TYPE and CONTEXT. + +See `doom-cli-log-file-format' for details." + (format doom-cli-log-file-format + (doom-cli-context-prefix context) + (doom-cli-context-sid context) + type)) + +(defun doom-cli--output (out &optional context) + "A `standard-output' function which mirrors output to log buffers." + (let ((str (char-to-string out))) + (dolist (buffer (list (doom-cli-context-stdout context) + (doom-cli-context-stderr context))) + (when (bufferp buffer) + (princ str buffer))) + (send-string-to-terminal str))) + +(defun doom-cli--output-read-stdin (buffer) + (with-current-buffer buffer + (let (in) + (while (setq in (ignore-errors (read-from-minibuffer ""))) + (insert in "\n")) + (when in + (delete-char -1))))) + +(defun doom-cli--output-write-logs-h (context) + "Write all log buffers to their appropriate files." + ;; Delete the last `doom-cli-log-retain' logs + (mapc #'delete-file + (let ((prefix (doom-cli-context-prefix context))) + (append (butlast (doom-glob (format doom-cli-log-file-format prefix "*" "log")) + doom-cli-log-retain) + (butlast (doom-glob (format doom-cli-log-file-format prefix "*" "error")) + doom-cli-log-retain)))) + ;; Then write the log file, if necessary + (let* ((buffer (doom-cli-context-stderr context)) + (file (doom-cli--output-file "log" context))) + (when (> (buffer-size buffer) 0) + (make-directory (file-name-directory file) t) + (with-temp-file file + (insert-buffer-substring buffer) + (ansi-color-filter-region (point-min) (point-max))) + (set-file-modes file #o600)))) + +(defun doom-cli--output-benchmark-h (context) + "Write this session's benchmark to stdout or stderr, depending. + +Will also output it to stdout if requested (CLI sets :benchmark to t) or the +command takes >5s to run. If :benchmark is explicitly set to nil (or +`doom-cli-benchmark-threshold' is nil), under no condition should a benchmark be +shown." + (when-let* ((init-time (doom-cli-context-init-time context)) + (cli (doom-cli-get context)) + (duration (float-time (time-subtract (current-time) init-time))) + (hours (/ (truncate duration) 60 60)) + (minutes (- (/ (truncate duration) 60) (* hours 60))) + (seconds (- duration (* hours 60 60) (* minutes 60))) + (standard-output + (if (and (/= doom-cli--exit-code 0) + (or doom-debug-p + (eq (doom-cli-prop cli :benchmark) t) + (and (eq (doom-cli-prop cli :benchmark :null) :null) + (not (doom-cli-context-pipe-p context 'out t)) + (> duration (or doom-cli-benchmark-threshold + most-positive-fixnum))))) + (doom-rpartial #'doom-cli--output context) + (doom-cli-context-stderr context)))) + (print! (success "Finished in %s") + (join (list (unless (zerop hours) (format "%dh" hours)) + (unless (zerop minutes) (format "%dm" minutes)) + (format (if (> duration 60) "%ds" "%.5fs") + seconds)))) + (doom-log "GC count: %d (%.6fs)" gcs-done gc-elapsed))) + +(defun doom-cli--redirect-output-a (context message &rest args) + ":override advice for `message' to mirror output to log buffers" + (when message + (let ((output (apply #'doom-print--format message args))) + ;; One for the terminal, if the log level is high enough. + (doom-print output :format nil :level doom-print-message-level) + ;; And one for the logs... + (when (doom-cli-context-p context) + (doom-print output :format nil :stream (doom-cli-context-stderr context) :level t))) + message)) + + +;; +;;; Session management + +(defun doom-cli-call (args context &optional error) + "Process ARGS (list of string shell arguments) with CONTEXT as the basis. + +If ERROR is provided, store the error in CONTEXT, in case a later CLI wants to +read/use it (e.g. like a :help CLI)." + (when-let (command (doom-cli-context-command context)) + (push command (doom-cli-context-path context))) + (when error + (setf (doom-cli-context-error context) error)) + (setf (doom-cli-context-command context) nil + (doom-cli-context-arguments context) nil + (doom-cli-context-meta-p context) nil) + (doom-log "doom-cli-call: %s" args) + (doom-cli-context-execute + (doom-cli-context-parse args (or context doom-cli--context)))) + +(defun doom-cli--restart (args context) + "Restart the current CLI session. + +If CONTEXT is non-nil, this is written to file and restored in the next Doom +session. + +This is done by writing a temporary shell script, which is executed after this +session ends (see the shebang lines of this file). It's done this way because +Emacs' batch library lacks an implementation of the exec system call." + (unless (doom-cli-context-p context) + (error "Attempted `doom-cli--restart' without active context")) + (when (= (doom-cli-context-step context) -1) + (error "__DOOMSTEP envvar missing; extended `exit!' functionality will not work")) + (let* ((pid (doom-cli-context-pid context)) + (step (doom-cli-context-step context)) + (context-file (format (doom-path temporary-file-directory "doom.%s.%s.context") pid step)) + (script-file (format (doom-path temporary-file-directory "doom.%s.%s.sh") pid step)) + (command (if (listp args) (combine-and-quote-strings (remq nil args)) args)) + (coding-system-for-write 'utf-8-auto) + (coding-system-for-read 'utf-8-auto)) + (cl-incf (doom-cli-context-step context)) + (make-directory (file-name-directory context-file) t) + (with-temp-file context-file + ;; DEPRECATED Use `print-unreadable-function' when 28 support is dropped + (let ((newcontext (copy-doom-cli-context context)) + (print-level nil) + (print-length nil) + (print-circle nil) + (print-escape-newlines t)) + (letf! (defmacro convert-buffer (fn) + `(setf (,fn newcontext) (with-current-buffer (,fn context) + (buffer-string)))) + (convert-buffer doom-cli-context-stdin) + (convert-buffer doom-cli-context-stdout) + (convert-buffer doom-cli-context-stderr)) + (prin1 newcontext (current-buffer)))) + (set-file-modes context-file #o400) + (setenv "__DOOMCONTEXT" context-file) + (make-directory (file-name-directory script-file) t) + (with-temp-file script-file + (setq-local coding-system-for-write 'utf-8-auto) + (insert "#!/usr/bin/env sh\n" + "trap _doomcleanup EXIT\n" + "_doomcleanup() {\n" + " rm -" (if doom-debug-p "v" "") "f " + (combine-and-quote-strings (delq nil (list script-file context-file))) + "\n}\n" + "_doomrun() {\n " command "\n}\n" + (save-match-data + (cl-loop with initial-env = (get 'process-environment 'initial-value) + for env in (seq-difference process-environment initial-env) + if (string-match "^\\([a-zA-Z0-9_]+\\|__DOOM[^=]+\\)=\\(.+\\)$" env) + concat (format "%s=%s \\\n" + (match-string 1 env) + (shell-quote-argument (match-string 2 env))))) + (format "PATH=\"%s%s$PATH\" \\\n" + (doom-path doom-emacs-dir "bin") + path-separator) + "_doomrun \"$@\"\n")) + (set-file-modes script-file #o600) + ;; Error code 254 is special: it indicates to the caller that the + ;; post-script should be executed after this session ends. It's up to + ;; `doom-cli-run's caller to enforce this (see bin/doom's shebang for a + ;; comprehensive example). + (doom-cli--exit 254 context))) + +(defun doom-cli--exit (args context) + "Accepts one of the following: + + (CONTEXT [ARGS...]) + TODO + (STRING [ARGS...]) + TODO + (:restart [ARGS...]) + TODO + (:pager [FILE...]) + TODO + (:pager? [FILE...]) + TODO + (INT) + TODO" + (let ((command (or (car-safe args) args)) + (args (if (car-safe args) (cdr-safe args)))) + (pcase command + ;; If an integer, treat it as an exit code. + ((pred (integerp)) + (setq doom-cli--exit-code command) + (kill-emacs command)) + + ;; Otherwise, run a command verbatim. + ((pred (stringp)) + (doom-cli--restart (format "%s %s" command (combine-and-quote-strings args)) + context)) + + ;; Same with buffers. + ((pred (bufferp)) + (doom-cli--restart (with-current-buffer command (buffer-string)) + context)) + + ;; If a context is given, restart the current session with the new context. + ((pred (doom-cli-context-p)) + (doom-cli--exit-restart args command)) + + ;; Run a custom action, defined in `doom-cli-exit-commands'. + ((pred (keywordp)) + (if-let (fn (alist-get command doom-cli-exit-commands)) + (funcall fn args context) + (error "Invalid exit command: %s" command))) + + ;; Any other value is invalid. + (_ (error "Invalid exit code or command: %s" command))))) + +(defun doom-cli--exit-restart (args context) + "Restart the session, verbatim (persisting CONTEXT)." + (doom-cli--exit (cons "$@" args) context)) + +(defun doom-cli--exit-pager (args context) + "Invoke pager on output unconditionally. + +ARGS are options passed to less. If DOOMPAGER is set, ARGS are ignored." + (cond ((null (or doom-cli-pager (executable-find "less"))) + (user-error "No pager set or available") + (doom-cli--exit 1 context)) + + ((doom-cli-context-pipe-p context :out t) + (doom-cli--exit 0 context)) + + ((let ((tmpfile (doom-cli--output-file 'output context)) + (coding-system-for-write 'utf-8-auto)) + (make-directory (file-name-directory tmpfile) t) + (with-temp-file tmpfile + (insert-buffer-substring (doom-cli-context-stdout context))) + (set-file-modes tmpfile #o600) + (doom-cli--restart + (format "${DOOMPAGER:-less %s} <%s; rm -f%s %s" + (combine-and-quote-strings (or args '("+g"))) + (shell-quote-argument tmpfile) + (if doom-debug-p "v" "") + (shell-quote-argument tmpfile)) + context))))) + +(defun doom-cli--exit-pager-maybe (args context) + "Invoke pager if stdout is longer than TTY height * `doom-cli-pager-ratio'. + +ARGS are options passed to less. If DOOMPAGER is set, ARGS are ignored." + (doom-cli--exit + (let ((threshold (ceiling (* (doom-cli-context-height context) + doom-cli-pager-ratio)))) + (if (>= (let ((stdout (doom-cli-context-stdout context))) + (if (fboundp 'buffer-line-statistics) + (car (buffer-line-statistics stdout)) + (with-current-buffer stdout + (count-lines (point-min) (point-max))))) + threshold) + (cons :pager args) + 0)) + context)) + +;; (defun doom-cli--exit-editor (args context)) ; TODO Launch $EDITOR + +;; (defun doom-cli--exit-emacs (args context)) ; TODO Launch Emacs subsession + + +;; +;;; Misc + +(defun doom-cli-load (cli) + "If CLI is autoloaded, load it, otherwise return it unchanged." + (or (when-let* ((path (doom-cli-autoload cli)) + (path (locate-file-internal path doom-cli-load-path load-suffixes))) + (doom-log "Autoloading %s" path) + (let ((doom-cli--plist (doom-cli-plist cli))) + (load! path)) + (let* ((key (doom-cli-key cli)) + (cli (gethash key doom-cli--table))) + (when (doom-cli-autoload cli) + (signal 'doom-cli-autoload-error (list (doom-cli-command cli) path))) + cli)) + cli)) + +(defun doom-cli-load-all () + "Immediately load all autoloaded CLIs." + (dolist (key (hash-table-keys doom-cli--table)) + (doom-cli-load (gethash key doom-cli--table)))) + +(defun doom-cli--dump (&optional obj) + (let (kill-emacs-hook) + (prin1 obj) + (terpri) + (kill-emacs 0))) + + +;; +;;; DSL + +(defmacro defcli! (commandspec arglist &rest body) + "Defines a CLI command. + +COMMANDSPEC is the specification for the command that will trigger this CLI. It +can either be a symbol or list of symbols (or nested symbols). Nested lists are +treated as a list of aliases for the command. For example: + + (defcli! doom () ...) ; invoked on 'doom' + (defcli! (doom foo) () ...) ; invoked on 'doom foo' + (defcli! (doom (foo bar)) () ...) ; invoked on 'doom foo' or 'doom bar' + +COMMANDSPEC may be prefixed with any of these special keywords: + + :root ... + This command will ignore any :prefix set by a parent `defgroup!'. + :before ... + This command will run before the specified command(s). + :after ... + This command will run after the specified command(s). + :version + A special handler, executed when 'X --version' is called. Define your own, + if you don't want it spewing Doom's version information. + :help COMMAND... + A special handler, executed when help documentation is requested for a + command. E.g. 'doom help foo' or 'doom foo --help' will call (:help foo). + You can define your own global :help handler, or one for a specific command. + +To interpolate values into COMMANDSPEC (e.g. to dynamically generate commands), +use the comma operator: + + (let ((somevar 'bfg)) + (defcli! (doom ,somevar) ...)) + +DOCSTRING is a string description; its first line should be a short summary +(under 60 characters) of what the command does. It will be used in the cramped +command listings served by help commands. The rest of DOCSTRING lines should be +no longer than 80 columns, and should go into greater detail. This documentation +may use `quoting' to appropriately highlight ARGUMENTS, --options, or $ENVVARS. + +DOCSTRING may also contain sections, denoted by a capitalized header ending with +a colon and newline, and its contents indented by 2 spaces. These will be +appended to the end of the help documentation for that command. These three +sections are special: + + SYNOPSIS: + These are appended to the pregenerated SYNOPSIS of any commands help + documentation. Use this to specify additional use cases and examples for the + command. + ARGUMENTS: + Use this to specify longer-form documentation for arguments. They are + appended to the auto-generated section of the same name. + OPTIONS: + Use this to specify longer-form documentation for options. They are appended + to the auto-generated section of the same name. Only the option needs to be + specified for its lookup behavior to work. See bin/doom's `doom' command as + an example. + +ARGLIST is a specification for options and arguments that is accepted by this +command. Arguments are represented by either a symbol or a cons cell where +(SYMBOL . DOCUMENTATION), and option specifications are lists in the following +formats: + + ([TYPE] VAR (FLAGSPEC... [ARGSPEC...]) [DESCRIPTION]) + + TYPE + Optional. One of &flag or &multi (which correspond to &flags and &multiple, + respectively, and are used for specifying a type inline, if desired). + VAR + Is the symbol to bind that option's value to. + FLAGSPEC + A list of switches or sub-lists thereof. Each switch is a string, e.g. + \"--foo\" \"-b\" \"--baz\". + + Nested lists will be treated as logical groups of switches in documentation. + E.g. for + + With (\"--foo\" \"--bar\" [ARGSPEC...]) you get: + + --foo, --bar + [Documentation] + + With ((\"--foo\") (\"--bar\") [ARGSPEC...]) you get: + + --foo + --bar + [Documentation] + + Use this to logically group options that have many, but semantically + distinct switches. + ARGSPEC + A list of arguments or sub-lists thereof. Each argument is either a string + or symbol. + + If a string, they are used verbatim as the argument's documentation. Use + this to document more complex specifications, like \"[user@]host[:port]\". + Use reference `quotes' to highlight arguments appropriately. + + If a symbol, this is equivalent to (upcase (format \"`%s'\" SYMBOL)), but + its arguments will also be implicitly validated against + `doom-cli-option-arg-types'. + + A nested list indicates that an argument accepts multiple types, and are + implicitly joined into \"`ARG1'|`ARG2'|...\". + + WARNING: If this option is a &flag, the option must not accept arguments. + Instead, use ARGSPEC to specify a single, default value (one of `:yes' or + `:no'). + DESCRIPTION + A one-line description of the option. Use reference `quotes' to + appropriately highlight arguments, options, and envvars. A syntax exists for + adding long-form option documentation from the CLI's docstring. See + DOCSTRING above. + +ARGLIST may be segmented with the following auxiliary keywords: + + &args ARG + The rest of the literal arguments are stored in ARG. + &cli ARG + The called `doom-cli' struct is bound to ARG. + &context ARG + The active `doom-cli-context' struct is bound to ARG. + &flags OPTION... + An option '--foo' declared after &flags will implicitly include a + '--no-foo', and will appear as \"--[no-]foo\" in 'doom help' docs. + &multiple OPTION... + Options specified after &multiple may be passed to the command multiple + times. Its symbol will be bound to a list of cons cells containing (FLAG . + VALUE). + &optional ARG... + Indicates that the (literal) arguments after it are optional. + &input ARG + ARG will be bound to the input piped in from stdin, as a string, or nil if + unavailable. If you want access to the original buffer, use + (doom-cli-context-stdin context) instead. + &rest ARG + All switches and arguments, unprocessed, after this command. If given, any + unrecognized switches will not throw an error. This will also prevent + subcommands beneath this command from being recognized. Use with care! + + Any non-option arguments before &optional, &rest, or &args are required. + +BODY is a list of arbitrary elisp forms that will be executed when this command +is called. BODY may begin with a plist to set metadata about it. The recognized +properties: + + :alias (CMD...) + Designates this command is an alias to CMD, which is a command specification + identical to COMMANDSPEC. + :benchmark BOOL + If non-nil, display a benchmark after the command finishes. + :deprecated BOOL|STR + If non-nil, display a deprecation notice when using the command (unless + piping output to another process). If given a string, it will be used as the + version specifier, indicating when the command was deprecated. + :disable BOOL + If non-nil, the command will not be defined. + :group (STR...) + A breadcrumb of group names to file this command under. They will be + organized by category in the CLI documentation (available through SCRIPT + {--help,-?,help}). + :hide BOOL + If non-nil, don't display this command in the help menu or in {ba,z}sh + completion (though it will still be callable). + :partial BOOL + If non-nil, this command is treated as partial, an intermediary command + intended as a stepping stone toward a non-partial command. E.g. were you to + define (doom foo bar), two \"partial\" commands are implicitly created: + \"doom\" and \"doom foo\". When called directly, partials will list its + subcommands and complain that a subcommand is rqeuired, rather than display + an 'unknown command' error. + :prefix (STR...) + A command path to prepend to the command name. This is more useful as part + of `defgroup!'s inheritance. + :since STR + Documentation property, displaying since what version this command has + existed. + :stub BOOL + If non-nil, throw a \"This command hasn't been implemented yet\" error when + it is invoked. + +The BODY of commands with a non-nil :alias, :disable, :partial, or :stub will be +ignored. + +\(fn COMMANDSPEC ARGLIST [DOCSTRING] &rest BODY...)" + (declare (indent 2) (doc-string 3)) + (let ((docstring (if (stringp (car body)) (pop body))) + (plist (let (plist) + (while (keywordp (car body)) + (push (pop body) plist) + (push (pop body) plist)) + (nreverse plist))) + options arguments bindings) + (let ((type '&required)) + (dolist (arg arglist) + (cond ((listp arg) + (let* ((inline-type (cdr (assq (car arg) doom-cli-option-types))) + (type (or inline-type type)) + (args (if inline-type (cdr arg) arg))) + (push (apply (or (alist-get type doom-cli-option-generators) + (signal 'doom-cli-definition-error + (cons "Invalid option type" type))) + args) + options) + (push (car args) bindings))) + ((memq arg doom-cli-argument-types) + (setq type arg)) + ((string-prefix-p "&" (symbol-name arg)) + (signal 'doom-cli-definition-error (cons "Invalid argument specifier" arg))) + ((push arg bindings) + (push arg (alist-get type arguments)))))) + (dolist (arg arguments) + (setcdr arg (nreverse (cdr arg)))) + `(let (;; Define function early to prevent overcapturing + (fn ,(let ((clisym (make-symbol "cli")) + (alistsym (make-symbol "alist"))) + `(lambda (,clisym ,alistsym) + (let ,(cl-loop for arg in (nreverse bindings) + unless (string-prefix-p "_" (symbol-name arg)) + collect `(,arg (cdr (assq ',arg ,alistsym)))) + ,@body))))) + ;; `cl-destructuring-bind's will validate keywords, so I don't have to + (cl-destructuring-bind + (&whole plist &key + alias autoload _benchmark docs disable hide _group _obsolete + partial _prefix stub) + (append (list ,@plist) doom-cli--plist) + (unless disable + (let* ((command (doom-cli-command-normalize (backquote ,commandspec) plist)) + (type (if (keywordp (car command)) (pop command))) + (commands (doom-cli--command-expand command t)) + (target (pop commands))) + (dolist (prop '(:autoload :alias :partial :hide)) + (cl-callf map-delete plist prop)) + (puthash (delq nil (cons type target)) + (make-doom-cli + :command target + :type type + :docs ',(doom-cli--parse-docs docstring) + :arguments ',arguments + :options ',(nreverse options) + :autoload autoload + :alias (if alias (doom-cli-command-normalize alias plist)) + :plist (append plist (list :hide (and (or stub hide type) t))) + :fn (unless (or partial autoload) fn)) + doom-cli--table) + (let ((docs (doom-cli--parse-docs docs))) + (dolist (alias (cl-loop for c in commands + while (= (length c) (length target)) + collect (pop commands))) + (puthash (delq nil (cons type alias)) + (make-doom-cli + :command alias + :type type + :docs docs + :alias target + :plist (append plist '(:hide t))) + doom-cli--table)) + (dolist (partial commands) + (let ((cli (gethash partial doom-cli--table))) + (when (or (null cli) (doom-cli-autoload cli)) + (puthash (delq nil (cons type partial)) + (make-doom-cli + :command partial + :type type + :docs docs + :plist (list :group (plist-get plist :group))) + doom-cli--table))))) + target)))))) + +(defmacro defalias! (commandspec target &rest plist) + "Define a CLI alias for TARGET at COMMANDSPEC. + +See `defcli!' for information about COMMANDSPEC. +TARGET is not a command specification, and should be a command list." + `(defcli! ,commandspec () :alias ',target ,@plist)) + +(defmacro defobsolete! (commandspec target when) + "Define an obsolete CLI COMMANDSPEC that refers users to NEW-COMMAND. + +See `defcli!' for information about COMMANDSPEC. +TARGET is simply a command list. +WHEN specifies what version this command was rendered obsolete." + `(defcli! ,commandspec (&context context &rest _) + :hide t + :obsolete ,when + (signal 'doom-cli-deprecated-error + (list (doom-cli-context-command context) + ,target + ,when)))) + +(defmacro defautoload! (commandspec &optional path &rest plist) + "Defer loading of PATHS until PREFIX is called." + `(let* ((doom-cli--plist (append (list ,@plist) doom-cli--plist)) + (commandspec (doom-cli-command-normalize ',commandspec doom-cli--plist)) + (commands (doom-cli--command-expand commandspec)) + (path (or ,path + (when-let* ((cmd (car commands)) + (last (car (last cmd))) + (last (if (listp last) (car last) last))) + (format "%s" last)) + (error "Failed to deduce autoload path for: %s" spec))) + (cli (doom-cli-get (car commands) nil t))) + (when (or (null cli) + (doom-cli-autoload cli)) + (defcli! ,commandspec () :autoload path)))) + +(defmacro defgroup! (&rest body) + "Declare common properties for any CLI commands defined in BODY." + (when (stringp (car body)) + (push :group body)) + `(let ((doom-cli--plist (copy-sequence doom-cli--plist))) + ,@(let (forms) + (while (keywordp (car body)) + (let ((key (pop body)) + (val (pop body))) + (push `(cl-callf plist-put doom-cli--plist + ,key ,(if (eq key :prefix) + `(append (plist-get doom-cli--plist ,key) + (doom-enlist ,val)) + val)) + forms))) + (nreverse forms)) + ,@body)) + +(defun exit! (&rest args) + "Exits the current CLI session. + +With ARGS, you may specify a shell command or action (see +`doom-cli-exit-commands') to execute after this Emacs process has ended. For +example: + + (exit! \"$@\") or (exit! :restart) + This reruns the current command with the same arguments. + (exit! \"$@ -h -c\") + This reruns the current command with two new switches. + (exit! \"emacs -nw FILE\") + Opens Emacs on FILE + (exit! t) or (exit! nil) + A safe way to simply abort back to the shell with exit code 0 + (exit! 42) + Abort to shell with an explicit exit code. + (exit! context) + Restarts the current session, but with context (a `doom-cli-context' struct). + +See `doom-cli--restart' for implementation details." + (doom-cli--exit (flatten-list args) doom-cli--context)) + +(defun call! (&rest command) + "A convenience wrapper around `doom-cli-call'. + +Implicitly resolves COMMAND relative to the running CLI, and uses the active +context (so you don't have to pass a context)." + (doom-cli-call (doom-cli-command-normalize + (flatten-list command) + `(:prefix + ,(doom-cli-context-prefix doom-cli--context) + ,@(doom-cli-context-command doom-cli--context))) + doom-cli--context)) + +(defun run! (prefix &rest args) + "Parse and execute ARGS. + +This is the entry point for any shell script that rely on Doom's CLI framework. +It should be called once, at top-level, and never again (use `doom-cli-call' for +nested calls instead). + +PREFIX is the name (string) of the top-level shell script (i.e. $0). All +commands that belong to this shell session should use PREFIX as the first +segment in their command paths. + +ARGS is a list of string arguments to execute. + +See bin/doom's shebang for an example of what state needs to be initialized for +Doom's CLI framework. In a nutshell, Doom is expecting the following environment +variables to be set: + + __DOOMGEOM The dimensions of the current terminal (W . H) + __DOOMPIPE Must contain 0 if script is being piped into, 1 if piping it out + __DOOMGPIPE Like __DOOMPIPE, but is the pipe state of the super process + __DOOMPID A unique ID for this session and its exit script processes + __DOOMSTEP How many layers deep this session has gotten + +The script should also execute ${temporary-file-directory}/doom.sh if Emacs +exits with code 254. This script is auto-generated as needed, to simulate exec +syscalls. See `doom-cli--restart' for technical details. + +Once done, this function kills Emacs gracefully and writes output to log files +(stdout to `doom-cli--output-file', stderr to `doom-cli-debug-file', and any +errors to `doom-cli-error-file')." + (when doom-cli--context + (error "Cannot nest `run!' calls")) + (let ((args (flatten-list args))) + (if (and doom-cli--dump (equal args '("-"))) + (doom-cli--dump + (progn (doom-cli-load-all) + (hash-table-values doom-cli--table))) + (letf! ((context (make-doom-cli-context :prefix prefix)) + (doom-cli--context context) + (write-logs-fn (doom-partial #'doom-cli--output-write-logs-h context)) + (show-benchmark-fn (doom-partial #'doom-cli--output-benchmark-h context)) + ;; Write more user-friendly backtraces + (debugger (doom-rpartial #'doom-cli-debugger context)) + (debug-on-error t) + ;; Clone output to stdout/stderr buffers for logging. + (standard-output (doom-rpartial #'doom-cli--output context)) + (#'message (doom-partial #'doom-cli--redirect-output-a context))) + (doom-log "Starting!") + (add-hook 'kill-emacs-hook show-benchmark-fn 94) + (add-hook 'kill-emacs-hook write-logs-fn 95) + (when (doom-cli-context-pipe-p context :out t) + (setq doom-print-backend nil)) + (when (doom-cli-context-pipe-p context :in) + (doom-cli--output-read-stdin (doom-cli-context-stdin context))) + (doom-log "doom-cli-run: %s" command-line-args) + (doom-cli--exit + (condition-case e + (let ((context + (or (doom-cli-context-restore (getenv "__DOOMCONTEXT") context) + (doom-cli-context-parse (cons prefix args) context)))) + (run-hook-with-args 'doom-cli-before-run-functions context) + (let ((result (doom-cli-context-execute context))) + (run-hook-with-args 'doom-cli-after-run-functions context result)) + 0) + (doom-cli-wrong-number-of-arguments-error + (pcase-let ((`(,command ,flag ,args ,min ,max) (cdr e))) + (print! (red "Error: %S expected %s argument%s, but got %d") + (or flag (doom-cli-command-string (cdr command))) + (if (or (= min max) + (= max most-positive-fixnum)) + min + (format "%d-%d" min max)) + (if (or (= min 0) (> min 1)) "s" "") + (length args)) + (doom-cli-call `(:help "--synopsis" "--postamble" ,@(cdr command)) context e)) + 5) + (doom-cli-unrecognized-option-error + (print! (red "Error: unknown option %s") (cadr e)) + (doom-cli-call `(:help "--synopsis" "--postamble" ,@(cdr (doom-cli--command context))) context e) + 5) + (doom-cli-invalid-option-error + (pcase-let ((`(,types ,option ,value ,errors) (cdr e))) + (print! (red "Error: %s received invalid value %S") + (string-join (doom-cli-option-switches option) "/") + value) + (print! (bold "\nValidation errors:")) + (dolist (err errors) (print! (item "%s." (fill err))))) + (doom-cli-call `(:help "--postamble" ,@(cdr (doom-cli--command context))) context e) + 5) + (doom-cli-command-not-found-error + (let* ((command (cdr e)) + (cli (doom-cli-get command))) + (cond ((null cli) + (print! (red "Error: unrecognized command '%s'") + (doom-cli-command-string (or (cdr command) command))) + (doom-cli-call `(:help "--similar" "--postamble" ,@(cdr command)) context e)) + ((null (doom-cli-fn cli)) + (print! (red "Error: a subcommand is required")) + (doom-cli-call `(:help "--subcommands" "--postamble" ,@(cdr command)) context e)))) + 4) + (doom-cli-invalid-prefix-error + (let ((prefix (cadr e))) + (print! (red "Error: `run!' called with invalid prefix %S") prefix) + (if-let (suggested (cl-loop for cli being the hash-value of doom-cli--table + unless (doom-cli-type cli) + return (car (doom-cli-command cli)))) + (print! "Did you mean %S?" suggested) + (print! "There are no commands defined under %S." prefix))) + 4) + (doom-cli-deprecated-error + (pcase-let ((`(,command ,replacement ,when) (cdr e))) + (print! (yellow "Error: %S was removed in %s") + (doom-cli-command-string command) + when) + (print-group! + (print! "\nUse %S instead." replacement))) + (doom-cli-call `(:help "--postamble" ,@(cdr command)) context e) + 4) + (user-error + (print! (red "Error: %s") (cadr e)) + (print! "\nAborting...") + 3)) + context))))) + +(defalias 'sh! #'doom-call-process) + +(defalias 'sh!! #'doom-exec-process) + +;; TODO Make `git!' into a more sophisticated wrapper around git +(defalias 'git! (doom-partial #'straight--process-run "git")) + +(provide 'core-cli-lib) +;;; core-cli-lib.el ends here diff --git a/core/core-cli.el b/core/core-cli.el index 9702aa38c..2e6251933 100644 --- a/core/core-cli.el +++ b/core/core-cli.el @@ -1,58 +1,110 @@ -;;; core/core-cli.el --- -*- lexical-binding: t; no-byte-compile: t; -*- +;;; core/core-cli.el --- The heart of Doom's CLI framework -*- lexical-binding: t; no-byte-compile: t; -*- +;;; Commentary: +;; +;; The heart of Doom's CLI framework. This is safe to load in interactive +;; sessions (for API access and syntax highlighting), but much of the API +;; expects a noninteractive session, so take care when testing code! +;; +;;; Code: -(defvar doom-auto-accept (getenv "YES") - "If non-nil, Doom will auto-accept any confirmation prompts during batch -commands like `doom-cli-packages-install', `doom-cli-packages-update' and -`doom-packages-autoremove'.") +(when (version< emacs-version "27.1") + (message + (concat + "Error: detected Emacs " emacs-version ", but 27.1 or newer is required.\n\n" + "The version of Emacs in use is located at:\n\n " (car command-line-args) "\n\n" + "A guide for installing a newer version of Emacs can be found at:\n\n " + (format "https://doomemacs.org/docs/getting_started.org#%s\n" + (cond ((eq system-type 'darwin) "on-macos") + ((memq system-type '(cygwin windows-nt ms-dos)) "on-windows") + ("on-linux"))) "\n" + "Alternatively, alter the EMACS environment variable to temporarily change what\n" + "command this script uses to invoke Emacs. For example:\n\n" + (let ((command (file-name-nondirectory (cadr (member "--load" command-line-args))))) + (concat " $ EMACS=/path/to/valid/emacs " command " ...\n" + " $ EMACS=\"/Applications/Emacs.app/Contents/MacOS/Emacs\" " command " ...\n" + " $ EMACS=\"snap run emacs\" " command " ...\n")) + "\nAborting...")) + (kill-emacs 2)) -(defvar doom-auto-discard (getenv "FORCE") - "If non-nil, discard all local changes while updating.") -(defvar doom-cli-file "cli" - "The basename of CLI config files for modules. +;; +;;; Variables -These are loaded when a Doom's CLI starts up. There users and modules can define -additional CLI commands, or reconfigure existing ones to better suit their -purpose.") +(defvar doom-cli--dump (getenv "__DOOMDUMP") + "If non-nil, dump target CLIs to stdout (or all of `doom-cli--table'). -(defvar doom-cli-log-file (concat doom-local-dir "doom.log") - "Where to write the extended output to.") +This exists so external tools or Doom binscripts can inspect each other.") -(defvar doom-cli-log-error-file (concat doom-local-dir "doom.error.log") - "Where to write the last backtrace to.") -(defvar doom--cli-log-buffer (generate-new-buffer " *doom log*")) -(defvar doom--cli-commands (make-hash-table :test 'equal)) -(defvar doom--cli-groups (make-hash-table :test 'equal)) -(defvar doom--cli-group nil) +;; +;;; Setup CLI session -(define-error 'doom-cli-error "There was an unexpected error" 'doom-error) -(define-error 'doom-cli-command-not-found-error "Could not find that command" 'doom-cli-error) -(define-error 'doom-cli-wrong-number-of-arguments-error "Wrong number of CLI arguments" 'doom-cli-error) -(define-error 'doom-cli-unrecognized-option-error "Not a recognized option" 'doom-cli-error) -(define-error 'doom-cli-deprecated-error "Command is deprecated" 'doom-cli-error) +;; The garbage collector isn't so important during CLI ops. A higher threshold +;; makes it 15-30% faster, but set it too high and we risk runaway memory usage +;; in longer sessions. +(setq gc-cons-threshold 134217728) ; 128mb + +;; Ensure errors are sufficiently detailed from this point on. +(setq debug-on-error t) + +;; HACK Load `cl' and site files manually to prevent polluting logs and stdout +;; with deprecation and/or file load messages. +(let ((inhibit-message t)) + (require 'cl) + (unless site-run-file + (let ((site-run-file "site-start") + (verbose (or (getenv "DEBUG") init-file-debug)) + (tail load-path) + (lispdir (expand-file-name "../lisp" data-directory)) + dir) + (while tail + (setq dir (car tail)) + (let ((default-directory dir)) + (load (expand-file-name "subdirs.el") t (not verbose) t)) + (or (string-prefix-p lispdir dir) + (let ((default-directory dir)) + (load (expand-file-name "leim-list.el") t (not verbose) t))) + (setq tail (cdr tail))) + (load site-run-file t (not verbose))))) + +;; Just the... bear necessities~ +(require 'core (expand-file-name "core" (file-name-directory load-file-name))) +(require 'seq) +(require 'map) + +;; Load these eagerly, since autoloads haven't been generated/loaded yet +(load! "autoload/process") +(load! "autoload/system") +(load! "autoload/plist") +(load! "autoload/files") +(load! "autoload/debug") +(load! "autoload/print") +;; (load! "autoload/autoloads") + +;; Ensure straight and core packages are ready to go for CLI commands. +(require 'core-modules) +(require 'core-packages) + +;; Don't generate superfluous files when writing temp buffers. +(setq make-backup-files nil) +;; Stop user configuration from interfering with package management. +(setq enable-dir-local-variables nil) +;; Reduce ambiguity, embrace specificity, enjoy predictability. +(setq-default case-fold-search nil) +;; Don't clog the user's trash with anything we clean up during this session. +(setq delete-by-moving-to-trash nil) ;; ;;; Bootstrap -(require 'seq) -(load! "autoload/process") -(load! "autoload/system") -(load! "autoload/plist") -(load! "autoload/files") -(load! "autoload/output") +;; Our DSL, API, and everything nice. +(require 'core-cli-lib) -(load! "cli/lib/debugger") -(load! "cli/lib/lib") -(load! "cli/lib/straight-hacks") - -;; Use our own home-grown debugger so we can capture and store backtraces, make -;; them more presentable, and make it easier for users to produce better bug -;; reports! -(setq debugger #'doom-cli--debugger - debug-on-error t - debug-ignored-errors '(user-error)) +;; Use our own home-grown debugger so we can capture backtraces, make them more +;; presentable, and write them to a file. Cleaner backtraces are better UX than +;; the giant wall of text the default debugger throws up. +(setq debugger #'doom-cli-debugger) ;; Create all our core directories to quell file errors. (mapc (doom-rpartial #'make-directory 'parents) @@ -60,214 +112,8 @@ purpose.") doom-etc-dir doom-cache-dir)) -;; Ensure straight and core packages are ready to go for CLI commands. -(require 'core-modules) -(require 'core-packages) -(doom-initialize-core-packages) - -;; Default to using all cores, rather than half of them, since we compile things -;; ahead-of-time in a non-interactive session. -(defadvice! doom--comp-use-all-cores-a (&rest _) - :before #'comp-effective-async-max-jobs - (setq comp-num-cpus (doom-system-cpus))) - - -;; -;;; Entry point - -(defcli! :doom - ((help-p ["-h" "--help"] "Same as help command") - (auto-accept-p ["-y" "--yes"] "Auto-accept all confirmation prompts") - (debug-p ["-d" "--debug"] "Enables on verbose output") - (loadfile ["-l" "--load" file] "Load an elisp FILE before executing any commands") - (doomdir ["--doomdir" dir] "Use the private module at DIR (e.g. ~/.doom.d)") - (localdir ["--localdir" dir] "Use DIR as your local storage directory") - (nocolor ["-C" "--nocolor"] "Disable colored output") - &optional command - &rest args) - "A command line interface for managing Doom Emacs. - -Includes package management, diagnostics, unit tests, and byte-compilation. - -This tool also makes it trivial to launch Emacs out of a different folder or -with a different private module. - -Environment variables: - EMACSDIR Where to find the Doom Emacs repo (normally ~/.emacs.d) - DOOMDIR Where to find your private Doom config (normally ~/.doom.d) - DOOMLOCALDIR Where to store local files (normally ~/.emacs.d/.local)" - (condition-case e - (with-output-to! doom--cli-log-buffer - (when nocolor - (setq doom-output-backend nil)) - (catch 'exit - (when (and (not (getenv "__DOOMRESTART")) - (or doomdir - localdir - debug-p - auto-accept-p)) - (when doomdir - (setenv "DOOMDIR" (file-name-as-directory doomdir)) - (print! (info "DOOMDIR=%s") doomdir)) - (when localdir - (setenv "DOOMLOCALDIR" (file-name-as-directory localdir)) - (print! (info "DOOMLOCALDIR=%s") localdir)) - (when debug-p - (setenv "DEBUG" "1") - (print! (info "DEBUG=1"))) - (when auto-accept-p - (setenv "YES" auto-accept-p) - (print! (info "Confirmations auto-accept enabled"))) - (throw 'exit "__DOOMRESTART=1 $@")) - (when loadfile - (load (doom-path loadfile) nil t t)) - (when help-p - (when command - (push command args)) - (setq command "help")) - (cons - t (if (null command) - (doom-cli-execute "help") - (let ((start-time (current-time))) - (run-hooks 'doom-cli-pre-hook) - (unless (getenv "__DOOMRESTART") - (print! (start "Executing 'doom %s' with Emacs %s at %s") - (string-join - (cons (or (ignore-errors - (doom-cli-name (doom-cli-get command))) - command) - args) - " ") - emacs-version - (format-time-string "%Y-%m-%d %H:%M:%S"))) - (print-group! - (when-let (result (apply #'doom-cli-execute command args)) - (run-hooks 'doom-cli-post-hook) - (print! (success "Finished in %s") - (let* ((duration (float-time (time-subtract (current-time) before-init-time))) - (hours (/ (truncate duration) 60 60)) - (minutes (- (/ (truncate duration) 60) (* hours 60))) - (seconds (- duration (* hours 60 60) (* minutes 60)))) - (string-join - (delq - nil (list (unless (zerop hours) (format "%dh" hours)) - (unless (zerop minutes) (format "%dm" minutes)) - (format (if (> duration 60) "%ds" "%.4fs") - seconds)))))) - result))))))) - ;; TODO Not implemented yet - (doom-cli-command-not-found-error - (print! (error "Command 'doom %s' not recognized") (string-join (cdr e) " ")) - (print! "\nDid you mean one of these commands?") - (apply #'doom-cli-execute "help" "--similar" (string-join (cdr e) " ")) - 5) - ;; TODO Not implemented yet - (doom-cli-wrong-number-of-arguments-error - (cl-destructuring-bind (route opt arg n d) (cdr e) - (print! (error "doom %s: %S requires %d arguments, but %d given\n") - (mapconcat #'symbol-name route " ") arg n d) - (print-group! - (apply #'doom-cli-execute "help" (mapcar #'symbol-name route)))) - 6) - ;; TODO Not implemented yet - (doom-cli-unrecognized-option-error - (let ((option (cadr e))) - (print! (error "Unrecognized option: %S") option) - (when (string-match "^--[^=]+=\\(.+\\)$" option) - (print! "The %S syntax isn't supported. Use '%s %s' instead." - option (car (split-string option "=")) - (match-string 1 option)))) - 7) - ;; TODO Not implemented yet - (doom-cli-deprecated-error - (cl-destructuring-bind (route . commands) (cdr e) - (print! (warn "The 'doom %s' command was removed and replaced with:\n") - (mapconcat #'symbol-name route " ")) - (print-group! - (dolist (command commands) - (print! (info "%s") command)))) - 8) - (user-error - (print! (warn "%s") (cadr e)) - 9))) - - -;; -;;; CLI Commands - +;; Load standard :help and :version handlers. (load! "cli/help") -(load! "cli/install") -(load! "cli/sync") -(load! "cli/env") -(load! "cli/upgrade") -(load! "cli/packages") -(load! "cli/autoloads") -(load! "cli/ci") - -(defcligroup! "Diagnostics" - "For troubleshooting and diagnostics" - (load! "cli/doctor") - (load! "cli/debug") - - ;; Our tests are broken at the moment. Working on fixing them, but for now we - ;; disable them: - ;; (load! "cli/test") - ) - -(defcligroup! "Compilation" - "For compiling Doom and your config" - (load! "cli/byte-compile")) - -(defcligroup! "Utilities" - "Conveniences for interacting with Doom externally" - (defcli! run (&rest args) - "Run Doom Emacs from bin/doom's parent directory. - -All arguments are passed on to Emacs. - - doom run - doom run -nw init.el - -WARNING: this command exists for convenience and testing. Doom will suffer -additional overhead by being started this way. For the best performance, it is -best to run Doom out of ~/.emacs.d and ~/.doom.d." - ;; TODO Does this work on Windows? - (let* ((tempdir (doom-path (temporary-file-directory) "doom.run")) - (tempemacsdir (doom-path tempdir ".emacs.d"))) - (delete-directory tempdir t) - (make-directory tempemacsdir t) - (with-temp-file (doom-path tempemacsdir "early-init.el") - (prin1 `(progn - (setenv "HOME" ,(getenv "HOME")) - (setq user-emacs-directory ,doom-emacs-dir) - (load ,(doom-path doom-emacs-dir "early-init.el") - nil ,(not doom-debug-mode)) - (define-advice startup--load-user-init-file (:filter-args (args) init-doom) - (cons (lambda () ,(doom-path doom-emacs-dir "init.el")) - (cdr args)))) - (current-buffer))) - (throw 'exit (format "HOME=%S %s %s" - tempdir invocation-name - (combine-and-quote-strings args)))))) - - -;; -;;; Bootstrap - -(doom-log "Initializing Doom CLI") -(load! doom-module-init-file doom-private-dir t) -(maphash (doom-module-loader doom-cli-file) doom-modules) -(load! doom-cli-file doom-private-dir t) - - -;; Don't generate superfluous files when writing temp buffers -(setq make-backup-files nil) -;; Stop user configuration from interfering with package management -(setq enable-dir-local-variables nil) -;; Reduce ambiguity, embrace specificity. It's more predictable. -(setq-default case-fold-search nil) -;; Don't clog the user's trash with anything we clean up in this session. -(setq delete-by-moving-to-trash nil) (provide 'core-cli) ;;; core-cli.el ends here diff --git a/core/core-lib.el b/core/core-lib.el index 9f17c996c..cb14d7326 100644 --- a/core/core-lib.el +++ b/core/core-lib.el @@ -70,23 +70,6 @@ list is returned as-is." (cl-check-type keyword keyword) (substring (symbol-name keyword) 1)) -(defmacro doom-log (format-string &rest args) - "Log to *Messages* if `doom-debug-p' is on. -Does not display text in echo area, but still logs to *Messages*. Accepts the -same arguments as `message'." - `(when doom-debug-p - (let ((inhibit-message t)) - (message - ,(concat (propertize "DOOM " 'face 'font-lock-comment-face) - (when (bound-and-true-p doom--current-module) - (propertize - (format "[%s/%s] " - (doom-keyword-name (car doom--current-module)) - (cdr doom--current-module)) - 'face 'warning)) - format-string) - ,@args)))) - (defalias 'doom-partial #'apply-partially) (defun doom-rpartial (fn &rest args) @@ -213,8 +196,8 @@ TRIGGER-HOOK is a list of quoted hooks and/or sharp-quoted functions." (defun file! () "Return the emacs lisp file this function is called from." - (cond ((bound-and-true-p byte-compile-current-file)) - (load-file-name) + (cond (load-in-progress load-file-name) + ((bound-and-true-p byte-compile-current-file)) ((stringp (car-safe current-load-list)) (car current-load-list)) (buffer-file-name) @@ -558,6 +541,8 @@ This is a wrapper around `eval-after-load' that: (cons 'doom-error doom-core-dir)) ((file-in-directory-p source doom-private-dir) (cons 'doom-private-error doom-private-dir)) + ((file-in-directory-p source (expand-file-name "cli" doom-core-dir)) + (cons 'doom-cli-error (expand-file-name "cli" doom-core-dir))) ((cons 'doom-module-error doom-emacs-dir))))) (signal (car err) (list (file-relative-name @@ -579,8 +564,8 @@ If NOERROR is non-nil, don't throw an error if the file doesn't exist." (error "Could not detect path to look for '%s' in" filename))) (file (if path - `(expand-file-name ,filename ,path) - filename))) + `(expand-file-name ,filename ,path) + filename))) `(condition-case-unless-debug e (let (file-name-handler-alist) (load ,file ,noerror 'nomessage)) diff --git a/modules/app/everywhere/cli.el b/modules/app/everywhere/cli.el index 819fdf4d3..1445da41f 100644 --- a/modules/app/everywhere/cli.el +++ b/modules/app/everywhere/cli.el @@ -1,5 +1,5 @@ ;;; app/everywhere/cli.el -*- lexical-binding: t; -*- -(defcli! everywhere () +(defcli! () () "Spawn an emacsclient window for quick edits." - (throw 'exit (list "emacsclient" "--eval" "(emacs-everywhere)"))) + (throw :exit "emacsclient --eval '(emacs-everywhere)'")) diff --git a/modules/config/literate/autoload.el b/modules/config/literate/autoload.el index 72a00436f..396238f48 100644 --- a/modules/config/literate/autoload.el +++ b/modules/config/literate/autoload.el @@ -27,7 +27,7 @@ byte-compiled from.") ;; Ensure output conforms to the formatting of all doom CLIs (defun message (msg &rest args) (when msg - (print! (info "%s") (apply #'format msg args))))) + (print! (item "%s") (apply #'format msg args))))) (print! (start "Compiling your literate config...")) (print-group! (let (;; Do as little unnecessary work as possible in these org files. @@ -53,8 +53,8 @@ byte-compiled from.") ;; Write an empty file to serve as our mtime cache (with-temp-file cache) (if doom-interactive-p t - (message "Restarting..." ) - (throw 'exit "__DOOMRESTART=1 __NOTANGLE=1 $@")))))) + (print! "Restarting...") + (exit! "__DOOMRESTART=1 __NOTANGLE=1 $@")))))) ;;;###autoload (defalias '+literate/reload #'doom/reload) diff --git a/modules/config/literate/cli.el b/modules/config/literate/cli.el index c1ba44cbb..878c1bee6 100644 --- a/modules/config/literate/cli.el +++ b/modules/config/literate/cli.el @@ -3,4 +3,4 @@ (load! "autoload") ;; Tangle the user's config.org before 'doom sync' runs -(add-hook 'doom-sync-pre-hook #'+literate-tangle-h) +(add-hook 'doom-before-sync-hook #'+literate-tangle-h) diff --git a/modules/lang/emacs-lisp/autoload.el b/modules/lang/emacs-lisp/autoload.el index a118a81cd..bec940661 100644 --- a/modules/lang/emacs-lisp/autoload.el +++ b/modules/lang/emacs-lisp/autoload.el @@ -239,6 +239,7 @@ https://emacs.stackexchange.com/questions/10230/how-to-indent-keywords-aligned" ("Advice" "^\\s-*(\\(?:def\\(?:\\(?:ine-\\)?advice!?\\)\\) +\\([^ )\n]+\\)" 1) ("Macros" "^\\s-*(\\(?:cl-\\)?def\\(?:ine-compile-macro\\|macro\\) +\\([^ )\n]+\\)" 1) ("Inline functions" "\\s-*(\\(?:cl-\\)?defsubst +\\([^ )\n]+\\)" 1) + ("CLI Command" "^\\s-*(\\(def\\(?:cli\\|alias\\|obsolete\\|autoload\\)! +\\([^\n]+\\)\\)" 1) ("Functions" "^\\s-*(\\(?:cl-\\)?def\\(?:un\\|un\\*\\|method\\|generic\\|-memoized!\\) +\\([^ ,)\n]+\\)" 1) ("Variables" "^\\s-*(\\(def\\(?:c\\(?:onst\\(?:ant\\)?\\|ustom\\)\\|ine-symbol-macro\\|parameter\\|var\\(?:-local\\)?\\)\\)\\s-+\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)+\\)" 2) ("Types" "^\\s-*(\\(cl-def\\(?:struct\\|type\\)\\|def\\(?:class\\|face\\|group\\|ine-\\(?:condition\\|error\\|widget\\)\\|package\\|struct\\|t\\(?:\\(?:hem\\|yp\\)e\\)\\)\\)\\s-+'?\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)+\\)" 2))))