emenel/doomemacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

refactor!(cli): rewrite CLI framework libraries

Browse source 
BREAKING CHANGE: this changes Doom's CLI framework in subtle ways, which
is listed in greater detail below. If you've never extended Doom's CLI,
then this won't affect you, but otherwise it'd be recommended you read
on below.

This commit focuses on the CLI framework itself and backports some
foundational changes to its DSL and how it resolves command line
arguments to CLIs, validates input, displays documentation, and persists
state across sessions -- and more. This is done in preparation for the
final stretch towarding completing the CLI rewrite (see #4273).

This is also an effort to generalize Doom's CLI (both its framework and
bin/doom), to increase it versatility and make it a viable dev tool for
other Doom projects (on our Github org) and beyond.

However, there is a *lot* to cover so I'll try to be brief:

- Refactor: generalize Doom's CLI framework by moving all bin/doom
  specific configuration/commands out of core-cli into bin/doom. This
  makes it easier to use bin/doom as a project-agnostic development
  tool (or for users to write their own).
- Refactor: change the namespace for CLI variables/functions from
  doom-cli-X to doom-X.
- Fix: subcommands being mistaken as arguments. "doom make index" will
  resolve to (defcli! (doom make index)) if it exists,
  otherwise (defcli! (doom make)) with "index" as an argument. Before
  this, it would resolve to the latter no matter what. &rest can
  override this; with (defcli! (doom make) (&rest args)), (defcli! (doom
  make index)) will never be invoked.
- Refactor!: redesign our output library (was core/autoload/output.el,
  is now core/autoload/print.el), and how our CLI framework buffers and
  logs output, and now merges logs across (exit! ...) restarts.
- Feat: add support for :before and :after pseudo commands. E.g.

    (defcli! (:before doom help) () ...)
    (defcli! (:after doom sync) () ...)

  Caveat: unlike advice, only one of each can be defined per-command.
- Feat: option arguments now have rudimentary type validation (see
  `doom-cli-option-arg-types`). E.g.

    (defcli! (doom foo) ((foo ("--foo" num))) ...)

  If NUM is not a numeric, it will throw a validation error.

  Any type that isn't in `doom-cli-option-arg-types` will be treated as a
  wildcard string type. `num` can also be replaced with a specification,
  e.g. "HOST[:PORT]", and can be formatted by using symbol quotes:
  "`HOST'[:`PORT']".
- Feat: it is no longer required that options *immediately* follow the command
  that defines them (but it must be somewhere after it, not before). E.g.
    With:
      (defcli! (:before doom foo) ((foo ("--foo"))) ...)
      (defcli! (doom foo baz) () ...)
    Before:
      FAIL: doom --foo foo baz
      GOOD: doom foo --foo baz
      FAIL: doom foo baz --foo
    After:
      FAIL: doom --foo foo baz
      GOOD: doom foo --foo baz
      GOOD: doom foo baz --foo
- Refactor: CLI session state is now kept in a doom-cli-context struct (which
  can be bound to a CLI-local variable with &context in the arglist):

    (defcli! (doom sync) (&context context)
      (print! "Command: " (doom-cli-context-command context)))

  These contexts are persisted across sessions (when restarted). This is
  necessary to support seamless script restarting (i.e. execve
  emulation) in post-3.0.
- Feat: Doom's CLI framework now understands "--". Everything after it will be
  treated as regular arguments, instead of sub-commands or options.
- Refactor!: the semantics of &rest for CLIs has changed. It used to be "all
  extra literal, non-option arguments". It now means *all* unprocessed
  arguments, and its use will suppress "unrecognized option" errors, and
  tells the framework not to process any further subcommands. Use &args
  if you just want "all literal arguments following this command".
- Feat: add new auxiliary keywords for CLI arglists: &context, &multiple,
  &flags, &args, &stdin, &whole, and &cli.
  - &context SYM: binds the currently running context to SYM (a
    `doom-cli-context` struct). Helpful for introspection or passing
    along state when calling subcommands by hand (with `call!`).
  - &stdin SYM: SYM will be bound to a string containing any input piped
    into the running script, or nil if none. Use
    `doom-cli-context-pipe-p` to detect whether the script has been
    piped into or out of.
  - &multiple OPTIONS...: allows all following OPTIONS to be repeated. E.g. "foo
    -x a -x b -x c" will pass (list ("-x" . "a") ("-x" . "b") ("-x" .
    "c")) as -x's value.
  - &flags OPTIONS...: All options after "&flags" get an implicit --no-* switch
    and cannot accept arguments. Will be set to :yes or :no depending on which flag is
    provided, and nil if the flag isn't provided. Otherwise, a default
    value can be specified in that options' arglist. E.g.

      (defcli! (doom foo) (&flags (foo ("--foo" :no))) ...)

    When called, this command sets FOO to :yes if --foo, :no if --no-foo, and
    defaults to :no otherwise.
  - &args SYM: this replaces what &rest used to be; it binds to SYM a
    list of all unprocessed (non-option) arguments.
  - &rest SYM: now binds SYM to a list of all unprocessed arguments, including
    options. This also suppresses "unrecognized option" errors, but will render
    any sub-commands inaccessible. E.g.

      (defcli! (doom make) (&rest rest) ...)
      ;; These are now inaccessible!
      (defcli! (doom make foo) (&rest rest) ...)
      (defcli! (doom make bar) (&rest rest) ...)
  - &cli SYM: binds SYM to the currently running `doom-cli` struct. Can also be
    obtained via `(doom-cli-get (doom-cli-context-command context))`. Possibly
    useful for introspection.
- feat: add defobsolete! macro for quickly defining obsolete commands.
- feat: add defalias! macro for quickly defining alias commands.
- feat: add defautoload! macro for defining an autoloaded command (won't
  be loaded until it is called for).
- refactor!: rename defcligroup! to defgroup! for consistency.
- fix: CLIs will now recursively inherit plist properties from parent
  defcli-group!'s (but will stack :prefix).
- refactor!: remove obsolete 'doom update':
- refactor!: further generalize 'doom ci'
  - In an effort to generalize 'doom ci' (so other Doom--or
    non-doom--projects can use it), all its subcommands have been
    changed to operate on the current working directory's repo instead
    of $EMACSDIR.
  - Doom-specific CI configuration was moved to .github/ci.el.
  - All 'doom ci' commands will now preload one of \$CURRENT_REPO_ROOT/ci.el or
    \$DOOMDIR/ci.el before executing.
- refactor!: changed 'doom env'
  - 'doom env {-c,--clear}' is now 'doom env {clear,c}'
  - -r/--reject and -a/--allow may now be specified multiple times
- refactor!: rewrote CLI help framework and error handling to be more
  sophisticated and detailed.
- feat: can now initiate $PAGER on output with (exit! :pager) (or use
  :pager? to only invoke pager is output is longer than the terminal is
  tall).
- refactor!: changed semantics+conventions for global bin/doom options
  - Single-character global options are now uppercased, to distinguish them from
    local options:
    - -d (for debug mode) is now -D
    - -y (to suppress prompts) is now -!
    - -l (to load elisp) is now -L
    - -h (short for --help) is now -?
  - Replace --yes/-y switches with --force/-!
  - -L/--load FILE: now silently ignores file errors.
  - Add --strict-load FILE: does the same as -L/--load, but throws an error if
    FILE does not exist/is unreadable.
  - Add -E/--eval FORM: evaluates arbitrary lisp before commands are processed.
  - -L/--load, --strict-load, and -E/--eval can now be used multiple times in
    one command.
  - Add --pager COMMAND to specify an explicit pager. Will also obey
    $DOOMPAGER envvar. Does not obey $PAGER.
- Fix #3746: which was likely caused by the generated post-script overwriting
  the old mid-execution. By salting the postscript filenames (with both an
  overarching session ID and a step counter).
- Docs: document websites, environment variables, and exit codes in
  'doom --help'
- Feat: add imenu support for def{cli,alias,obsolete}!

Ref: #4273
Fix: #3746
Fix: #3844
This commit is contained in:
Henrik Lissner 2022-06-18 19:16:06 +02:00
parent 6c5537b487
commit 6c0b7e1530
No known key found for this signature in database
GPG key ID: B60957CA074D39A3
28 changed files with 4068 additions and 1828 deletions
Download patch file Download diff file Expand all files Collapse all files

416
bin/doom
View file

@ -1,25 +1,81 @@
#!/usr/bin/env sh #!/usr/bin/env sh
:; set -e # -*- mode: emacs-lisp; lexical-binding: t -*- :; set -e # -*- mode: emacs-lisp; lexical-binding: t -*-
:; case "$EMACS" in *term*) EMACS=emacs ;; *) EMACS="${EMACS:-emacs}" ;; esac :; 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; } :; tmpdir=`$EMACS -Q --batch --eval '(princ (temporary-file-directory))' 2>/dev/null`
:; $EMACS --no-site-file --script "$0" -- "$@" || __DOOMCODE=$? :; [ -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; }
:; [ "${__DOOMCODE:-0}" -eq 128 ] && { sh "`$EMACS -Q --batch --eval '(princ temporary-file-directory)'`/doom.sh" "$0" "$@" && true; __DOOMCODE=$?; } :; export __DOOMPID="${__DOOMPID:-$$}"
:; exit $__DOOMCODE :; 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 ;; This magical mess of a shebang is necessary for any script that relies on
;; makes it 15-30% faster, but set it too high and we risk runaway memory usage ;; Doom's CLI framework, because Emacs' tty libraries and capabilities are too
;; in longer sessions. ;; immature (borderline non-existent) at the time of writing (28.1). This
(setq gc-cons-threshold 134217728) ; 128mb ;; 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 ;; Ensure Doom runs out of this file's parent directory (or $EMACSDIR), where
;; prevent loading stale byte-code. ;; Doom is presumably installed.
(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.
(setq user-emacs-directory (setq user-emacs-directory
(if (getenv-internal "EMACSDIR") (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 (expand-file-name
"../" (file-name-directory (file-truename load-file-name))))) "../" (file-name-directory (file-truename load-file-name)))))
@ -27,140 +83,222 @@
;; ;;
;;; Sanity checks ;;; 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) (when (equal (user-real-uid) 0)
;; If ~/.emacs.d is owned by root, assume the user genuinely wants root to be ;; 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))) (unless (= 0 (file-attribute-user-id (file-attributes user-emacs-directory)))
(error (message
(concat (concat
"Do not run this script as root. It will cause file permissions errors later.\n\n" "Error: this script is being run as root, which is likely not what you want.\n"
"To carry on anyway, change the owner of your Emacs config to root:\n\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" " 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 (require 'core-cli (expand-file-name "core/core-cli" user-emacs-directory))
;; 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)))))
;; 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 ;;; Entry point
;; 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)))
;; If a CLI command returns an integer, treat it as an exit code. (defcli! doom (&args _command)
((and (app car-safe `t) code) "A command line interface to Doom Emacs.
(if (integerp (cdr code))
(cdr code)))
;; CLI commands can do (throw 'exit SHELL-COMMAND) to run something after Includes package management, diagnostics, unit tests, and byte-compilation.
;; this session ends. e.g.
;; This tool also makes it trivial to launch Emacs out of a different folder or
;; (throw 'exit "$@") or (throw 'exit :restart) with a different private module.
;; This reruns the current command with the same arguments.
;; (throw 'exit "$@ -h -c") ENVIRONMENT VARIABLES:
;; This reruns the current command with two new switches. `$EMACS'
;; (throw 'exit "emacs -nw FILE") The Emacs executable or command to use for any Emacs operations in this or
;; Opens Emacs on FILE other Doom CLI shell scripts (default: first emacs found in `$PATH').
;; (throw 'exit t) or (throw 'exit nil)
;; A safe way to simply abort back to the shell with exit code 0 `$EMACSDIR'
;; (throw 'exit 42) The location of your Doom Emacs installation (defaults to ~/.config/emacs or
;; Abort to shell with an explicit exit code (as a more abrupt ~/.emacs.d; whichever is found first). This is *not* your private Doom
;; alternative to having the CLI command return 42). configuration. The `--emacsdir' option also sets this variable.
;;
;; How this works: the command is written to a temporary shell script which `$DOOMDIR'
;; is executed after this session ends (see the shebang lines of this file). The location of your private configuration for Doom Emacs (defaults to
;; It's done this way because Emacs' batch library lacks an implementation of ~/.config/doom or ~/.doom.d; whichever it finds first). This is *not* the
;; the exec system call. place you've cloned doomemacs/doomemacs to. The `--doomdir' option also sets
(command this variable.
(cond
((integerp command) `$DOOMPAGER'
command) The pager to invoke for large output (default: \"less +g\"). The `--pager'
((booleanp command) option also sets this variable.
0)
((let ((script (expand-file-name "doom.sh" temporary-file-directory)) `$DOOMPROFILE'
(coding-system-for-write 'utf-8-unix) (Not implemented yet) Which Doom profile to activate (default: \"current\").
(coding-system-for-read 'utf-8-unix))
(with-temp-file script `$DOOMPROFILESDIR'
(insert "#!/usr/bin/env sh\n" (Not implemented yet) Where to find or write generated Doom profiles
"_postscript() {\n" (default: `$EMACSDIR'/profiles).
" rm -f " (shell-quote-argument script) "\n "
(cond ((eq command :restart) "$@") EXIT CODES:
((stringp command) command) 0 Successful run
((listp command) 1 General internal error
(string-join 2 Error with Emacs/Doom install or execution context
(if (listp (car-safe command)) 3 Unrecognized user input error
(cl-loop for line in (doom-enlist command) 4 Command not found, or is incorrect/deprecated
collect (mapconcat #'shell-quote-argument (remq nil line) " ")) 5 Invalid, missing, or extra options/arguments
(list (mapconcat #'shell-quote-argument (remq nil command) " "))) 6-49 Reserved for Doom
"\n "))) 50-200 Reserved for custom user codes
"\n}\n" 254 Successful run (but then execute `doom-cli-restart-script')
(save-match-data 255 Uncaught internal errors
(cl-loop for env
in (cl-set-difference process-environment SEE ALSO:
(get 'process-environment 'initial-value) https://doomemacs.org Homepage
:test #'equal) https://docs.doomemacs.org Official documentation
if (string-match "^\\([a-zA-Z0-9_]+\\)=\\(.+\\)$" env) https://discourse.doomemacs.org Discourse (discussion & support forum)
concat (format "%s=%s \\\n" https://doomemacs.org/discord Discord chat server
(match-string 1 env) https://doomemacs.org/roadmap Development roadmap
(shell-quote-argument (match-string 2 env))))) https://git.doomemacs.org Shortcut to Github org
(format "PATH=\"%s%s$PATH\" \\\n" (concat doom-emacs-dir "bin/") path-separator) https://git.doomemacs.org/issues Global issue tracker"
"_postscript $@\n")) :partial t)
(set-file-modes script #o600)
;; Error code 128 is special: it means run the post-script after this (defcli! (:before doom)
;; session ends. ((force? ("-!" "--force") "Suppress prompts by auto-accepting their consequences")
128)))))) (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...

69
core/autoload/debug.el
View file

@ -7,7 +7,9 @@
(defvar doom-debug-variables (defvar doom-debug-variables
'(async-debug '(async-debug
debug-on-error debug-on-error
(debugger . doom-debugger)
doom-debug-p doom-debug-p
(doom-print-level . debug)
garbage-collection-messages garbage-collection-messages
gcmh-verbose gcmh-verbose
init-file-debug 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")))) (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 ;;; Time-stamped *Message* logs

278
core/autoload/output.el
View file

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

473
core/autoload/print.el Normal file
View file

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

33
core/cli/autoloads.el
View file

@ -30,6 +30,9 @@ one wants that.")
(defun doom-autoloads-reload (&optional file) (defun doom-autoloads-reload (&optional file)
"Regenerates Doom's autoloads and writes them to FILE." "Regenerates Doom's autoloads and writes them to FILE."
(unless 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)) (setq file doom-autoloads-file))
(print! (start "(Re)generating autoloads file...")) (print! (start "(Re)generating autoloads file..."))
(print-group! (print-group!
@ -59,7 +62,10 @@ one wants that.")
(seq-difference (hash-table-keys straight--build-cache) (seq-difference (hash-table-keys straight--build-cache)
doom-autoloads-excluded-packages)) doom-autoloads-excluded-packages))
doom-autoloads-excluded-files 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...")) (print! (start "Byte-compiling autoloads file..."))
(doom-autoloads--compile-file file) (doom-autoloads--compile-file file)
(print! (success "Generated %s") (print! (success "Generated %s")
@ -128,10 +134,10 @@ one wants that.")
(cond ((and (not module-enabled-p) altform) (cond ((and (not module-enabled-p) altform)
(print (read altform))) (print (read altform)))
((memq definer '(defun defmacro cl-defun cl-defmacro)) ((memq definer '(defun defmacro cl-defun cl-defmacro))
(if module-enabled-p (print
(print (make-autoload form file)) (if module-enabled-p
(cl-destructuring-bind (_ _ arglist &rest body) form (make-autoload form file)
(print (seq-let (_ _ arglist &rest body) form
(if altform (if altform
(read altform) (read altform)
(append (append
@ -141,21 +147,20 @@ one wants that.")
(_ type)) (_ type))
symbol arglist symbol arglist
(format "THIS FUNCTION DOES NOTHING BECAUSE %s IS DISABLED\n\n%s" (format "THIS FUNCTION DOES NOTHING BECAUSE %s IS DISABLED\n\n%s"
module module (if (stringp (car body))
(if (stringp (car body)) (pop body)
(pop body) "No documentation.")))
"No documentation.")))
(cl-loop for arg in arglist (cl-loop for arg in arglist
if (and (symbolp arg) if (symbolp arg)
(not (keywordp arg)) if (not (keywordp arg))
(not (memq arg cl--lambda-list-keywords))) if (not (memq arg cl--lambda-list-keywords))
collect arg into syms collect arg into syms
else if (listp arg) else if (listp arg)
collect (car arg) into syms collect (car arg) into syms
finally return (if syms `((ignore ,@syms))))))))) finally return (if syms `((ignore ,@syms)))))))))
(print `(put ',symbol 'doom-module ',module))) (print `(put ',symbol 'doom-module ',module)))
((eq definer 'defalias) ((eq definer 'defalias)
(cl-destructuring-bind (_ _ target &optional docstring) form (seq-let (_ _ target docstring) form
(unless module-enabled-p (unless module-enabled-p
(setq target #'ignore (setq target #'ignore
docstring docstring
@ -176,7 +181,7 @@ one wants that.")
;; the autoloads file. ;; the autoloads file.
debug-on-error debug-on-error
;; Non-nil interferes with autoload generation in Emacs < 29. See ;; Non-nil interferes with autoload generation in Emacs < 29. See
;; raxod502/straight.el#904. ;; radian-software/straight.el#904.
(left-margin 0) (left-margin 0)
;; The following bindings are in `package-generate-autoloads'. ;; The following bindings are in `package-generate-autoloads'.
;; Presumably for a good reason, so I just copied them. ;; Presumably for a good reason, so I just copied them.

231
core/cli/ci.el
View file

@ -1,60 +1,9 @@
;;; core/cli/ci.el -*- lexical-binding: t; -*- ;;; 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
(defvar doom-ci-commit-trailer-keys
(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
'(("Fix" ref hash url) '(("Fix" ref hash url)
("Ref" ref hash url) ("Ref" ref hash url)
("Close" ref) ("Close" ref)
@ -66,7 +15,7 @@
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-trailer-types (defvar doom-ci-commit-trailer-types
'((ref . "^\\(https?://[^ ]+\\|[^/]+/[^/]+\\)?#[0-9]+$") '((ref . "^\\(https?://[^ ]+\\|[^/]+/[^/]+\\)?#[0-9]+$")
(hash . "^\\(https?://[^ ]+\\|[^/]+/[^/]+@\\)?[a-z0-9]\\{12\\}$") (hash . "^\\(https?://[^ ]+\\|[^/]+/[^/]+@\\)?[a-z0-9]\\{12\\}$")
(url . "^https?://") (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.") 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) '(bump dev docs feat fix merge nit perf refactor release revert test tweak)
"A list of valid commit types.") "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. "A list of commit types whose scopes should be passed in its BODY.
Don't: \"bump(SCOPE): ...\" Don't: \"bump(SCOPE): ...\"
Do: \"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. "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 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 string, compared literally against the scope's name.
- A function predicate, taking two arguments (a scope as a symbol, and a plist - 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: for more about its structure). These predicates should:
- Return non-nil to immediately pass a scope. - Return non-nil to immediately pass a scope.
- Throw a `user-error' to immediately fail the 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)") '(docs \"faq\" \"install\" check-docs)")
(cl-defun doom-cli-enforce-scopeless-types (scope (&key type scopes summary &allow-other-keys)) (defvar doom-ci-commit-rules
"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
;; TODO Extract into named functions ;; TODO Extract into named functions
(list (fn! (&key subject) (list (fn! (&key subject)
"If a fixup/squash commit, don't lint this commit" "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) (fn! (&key type)
"Ensure commit has valid type" "Ensure commit has valid type"
(or (memq type doom-cli-commit-types) (or (memq type doom-ci-commit-types)
(if type (if type
(fail! "Invalid commit type: %s" type) (fail! "Invalid commit type: %s" type)
(fail! "Commit has no detectable type")))) (fail! "Commit has no detectable type"))))
@ -166,7 +109,7 @@ Each element of this list can be one of:
(and (listp rule) (and (listp rule)
(eq type (car rule)) (eq type (car rule))
(seq-find #'check-rule (cdr 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))) (fail! "Invalid scope: %s" scope)))
(user-error (fail! "%s" (error-message-string e)))))) (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. ;; TODO Add bump validations for revert: type.
(fn! (&key body trailers) (fn! (&key body trailers)
"Validate commit 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)) (key-re (regexp-opt keys t))
(lines (lines
;; Scan BODY because invalid trailers won't be in TRAILERS. ;; 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 "…") (truncate-string-to-width (string-trim line) 16 nil nil "…")
(match-string 1 line)))) (match-string 1 line))))
(pcase-dolist (`(,key . ,value) trailers) (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)) (string-match-p " " value))
(fail! "Found %S, but only one value allowed per trailer" (fail! "Found %S, but only one value allowed per trailer"
(truncate-string-to-width (concat key ": " value) 20 nil nil "…")) (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 (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) if (string-match-p it value)
return t) return t)
(fail! "%S expects one of %s, but got %S" (fail! "%S expects one of %s, but got %S"
@ -299,18 +242,98 @@ as `format'.
Note: warnings are not considered failures.") 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 (with-temp-buffer
(insert-file-contents file) (insert-file-contents file)
(doom-cli--ci--lint (doom-ci--lint
(list (cons `(("CURRENT" .
"CURRENT" ,(buffer-substring
(buffer-substring (point-min) (point-min)
(if (re-search-forward "^# Please enter the commit message" nil t) (if (re-search-forward "^# Please enter the commit message" nil t)
(match-beginning 0) (match-beginning 0)
(point-max)))))))) (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 (with-temp-buffer
(let ((z40 (make-string 40 ?0)) (let ((z40 (make-string 40 ?0))
line error) line error)
@ -318,6 +341,7 @@ Note: warnings are not considered failures.")
(catch 'continue (catch 'continue
(seq-let (local-ref local-sha remote-ref remote-sha) (seq-let (local-ref local-sha remote-ref remote-sha)
(split-string line " ") (split-string line " ")
;; TODO Extract this branch detection to a variable
(unless (or (string-match-p "^refs/heads/\\(master\\|main\\)$" remote-ref) (unless (or (string-match-p "^refs/heads/\\(master\\|main\\)$" remote-ref)
(equal local-sha z40)) (equal local-sha z40))
(throw 'continue t)) (throw 'continue t))
@ -325,7 +349,7 @@ Note: warnings are not considered failures.")
(mapc (lambda (commit) (mapc (lambda (commit)
(seq-let (hash msg) (split-string commit "\t") (seq-let (hash msg) (split-string commit "\t")
(setq error t) (setq error t)
(print! (info "%S commit in %s" (print! (item "%S commit in %s"
(car (split-string msg " ")) (car (split-string msg " "))
(substring hash 0 12))))) (substring hash 0 12)))))
(split-string (split-string
@ -339,13 +363,20 @@ Note: warnings are not considered failures.")
"\n" t)) "\n" t))
(when error (when error
(print! (error "Aborting push due to unrebased WIP, squash!, or fixup! commits")) (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 (with-temp-buffer
(save-excursion (insert commit-msg)) (save-excursion (insert commit-msg))
(append (append
@ -379,7 +410,7 @@ Note: warnings are not considered failures.")
(match-string 2))))) (match-string 2)))))
`(:bumps ,(cl-sort (delete-dups bumps) #'string-lessp :key #'car))))))) `(: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 (with-temp-buffer
(save-excursion (save-excursion
(insert (insert
@ -397,13 +428,13 @@ Note: warnings are not considered failures.")
(match-string 2))))) (match-string 2)))))
(cl-sort (delete-dups packages) #'string-lessp :key #'car))))) (cl-sort (delete-dups packages) #'string-lessp :key #'car)))))
(defun doom-cli--ci--lint (commits) (defun doom-ci--lint (commits)
(let ((warnings 0) (let ((warnings 0)
(failures 0)) (failures 0))
(print! (start "Linting %d commits" (length commits))) (print! (start "Linting %d commits" (length commits)))
(print-group! (print-group!
(pcase-dolist (`(,ref . ,commitmsg) commits) (pcase-dolist (`(,ref . ,commitmsg) commits)
(let* ((commit (doom-cli--parse-commit commitmsg)) (let* ((commit (doom-ci--parse-commit commitmsg))
(shortref (substring ref 0 7)) (shortref (substring ref 0 7))
(subject (plist-get commit :subject))) (subject (plist-get commit :subject)))
(cl-block 'linter (cl-block 'linter
@ -419,7 +450,7 @@ Note: warnings are not considered failures.")
(print! (start "%s %s") shortref subject) (print! (start "%s %s") shortref subject)
(print-group! (print-group!
(mapc (doom-rpartial #'apply commit) (mapc (doom-rpartial #'apply commit)
doom-cli-commit-rules))))))) doom-ci-commit-rules)))))))
(let ((issues (+ warnings failures))) (let ((issues (+ warnings failures)))
(if (= issues 0) (if (= issues 0)
(print! (success "There were no issues!")) (print! (success "There were no issues!"))
@ -427,26 +458,8 @@ Note: warnings are not considered failures.")
(if (> failures 0) (print! (warn "Failures: %d" failures))) (if (> failures 0) (print! (warn "Failures: %d" failures)))
(print! "\nSee https://discourse.doomemacs.org/git-conventions") (print! "\nSee https://discourse.doomemacs.org/git-conventions")
(unless (zerop failures) (unless (zerop failures)
(throw 'exit 1))) (exit! 1)))
t))) t)))
(defun doom-cli--ci-lint-commits (from &optional to) (provide 'core-cli-ci)
(with-temp-buffer ;;; ci.el ends here
(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))))

72
core/cli/byte-compile.el → core/cli/compile.el
View file

@ -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"]) ;;; Variables
(core-p ["-c" "--core"])
(private-p ["-p" "--private"]) ;; None yet!
(verbose-p ["-v" "--verbose"]))
;;
;;; 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. "Byte-compiles your config or selected modules.
compile [TARGETS...] compile [TARGETS...]
@ -14,7 +23,7 @@
Accepts :core and :private as special arguments, which target Doom's core files Accepts :core and :private as special arguments, which target Doom's core files
and your private config files, respectively. To recompile your packages, use and your private config files, respectively. To recompile your packages, use
'doom build' instead." 'doom build' instead."
(doom-cli-byte-compile (doom-cli-compile
(if (or core-p private-p) (if (or core-p private-p)
(append (if core-p (doom-glob doom-emacs-dir "init.el")) (append (if core-p (doom-glob doom-emacs-dir "init.el"))
(if core-p (list doom-core-dir)) (if core-p (list doom-core-dir))
@ -38,23 +47,13 @@ and your private config files, respectively. To recompile your packages, use
(defcli! clean () (defcli! clean ()
"Delete all *.elc files." "Delete all *.elc files."
:bare t (doom-compile-clean))
(doom-clean-byte-compiled-files))
;; ;;
;; Helpers ;;; Helpers
(defun doom--byte-compile-ignore-file-p (path) (cl-defun doom-cli-compile (&optional targets recompile-p verbose-p)
(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)
"Byte compiles your emacs configuration. "Byte compiles your emacs configuration.
init.el is always byte-compiled by this. 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 difficult. It is recommended you don't use it unless you understand the
reprecussions. reprecussions.
Use `doom-clean-byte-compiled-files' or `make clean' to reverse Use `doom-compile-clean' or `make clean' to reverse
byte-compilation. byte-compilation.
If RECOMPILE-P is non-nil, only recompile out-of-date files." 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 ;; 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 ;; they are loaded in, so we don't run into any scary catch-22s
;; while byte-compiling, like missing macros. ;; 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) (lambda (path)
(and (not (doom--byte-compile-ignore-file-p path)) (and (not (doom-compile--ignore-file-p path))
(cl-find-if (doom-partial #'file-in-directory-p path) (seq-find (doom-partial #'file-in-directory-p path)
target-dirs) target-dirs)
(cl-pushnew path targets)))) (cl-pushnew path targets))))
after-load-functions)))) after-load-functions))))
(doom-log "Reloading Doom in preparation for byte-compilation") (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)))) (quiet! (doom-initialize-modules))))
(if (null targets) (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...") (print! (start "%scompiling your config...")
(if recompile-p "Re" "Byte-")) (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))) (setq targets (cl-remove-if #'file-directory-p targets)))
(prependq! targets (prependq! targets
(doom-files-in (doom-files-in
dir :match "\\.el" :filter #'doom--byte-compile-ignore-file-p))) dir :match "\\.el" :filter #'doom-compile--ignore-file-p)))
(print-group! (print-group!
(require 'use-package) (require 'use-package)
@ -164,8 +163,7 @@ If RECOMPILE-P is non-nil, only recompile out-of-date files."
(byte-compile-file target) (byte-compile-file target)
(quiet! (byte-compile-file target)))) (quiet! (byte-compile-file target))))
(`no-byte-compile (`no-byte-compile
(print! (debug "(% 3d/%d) Ignored %s") (doom-log "(% 3d/%d) Ignored %s" i total-modules (relpath target))
i total-modules (relpath target))
total-noop) total-noop)
(`nil (`nil
(print! (error "(% 3d/%d) Failed to compile %s") (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...") "Reverting changes...")
(signal 'doom-error (list 'byte-compile e)))))))) (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 "Delete all the compiled elc files in your Emacs configuration and private
module. This does not include your byte-compiled, third party packages.'" module. This does not include your byte-compiled, third party packages.'"
(require 'core-modules) (require 'core-modules)
@ -204,5 +211,8 @@ module. This does not include your byte-compiled, third party packages.'"
finally do finally do
(print! (if (> success 0) (print! (if (> success 0)
(success "\033[K%d elc files deleted" success) (success "\033[K%d elc files deleted" success)
(info "\033[KNo elc files to clean")))) (item "\033[KNo elc files to clean"))))
t)) t))
(provide 'core-cli-compile)
;;; compile.el ends here

86
core/cli/debug.el
View file

@ -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 "\\_<GNUTLS\\_>" 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)))))

79
core/cli/doctor.el
View file

@ -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-doctor--warnings ())
(defvar doom-errors ()) (defvar doom-doctor--errors ())
;;
;;; DSL
;;; Helpers
(defun elc-check-dir (dir) (defun elc-check-dir (dir)
(dolist (file (directory-files-recursively dir "\\.elc$")) (dolist (file (directory-files-recursively dir "\\.elc$"))
(when (file-newer-than-file-p (concat (file-name-sans-extension file) ".el") (when (file-newer-than-file-p (concat (file-name-sans-extension file) ".el")
@ -14,27 +19,28 @@
`(unless ,condition `(unless ,condition
(error! ,message ,@args))) (error! ,message ,@args)))
;;; Logging
(defmacro error! (&rest args) (defmacro error! (&rest args)
`(progn (unless inhibit-message (print! (error ,@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) (defmacro warn! (&rest args)
`(progn (unless inhibit-message (print! (warn ,@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) (defmacro success! (&rest args)
`(print! (green ,@args))) `(print! (green ,@args)))
(defmacro section! (&rest args) (defmacro section! (&rest args)
`(print! (bold (blue ,@args)))) `(print! (bold (blue ,@args))))
(defmacro explain! (&rest args) (defmacro explain! (&rest args)
`(print-group! (print! (autofill ,@args)))) `(print-group! (print! (fill (string-join (list ,@args) "\n")))))
;; ;;
;;; CLI commands ;;; CLI commands
(defcli! (doctor doc) () (defcli! ((doctor doc)) ()
"Diagnoses common issues on your system. "Diagnoses common issues on your system.
The Doom doctor is essentially one big, self-contained elisp shell script that 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 Doom modules may optionally have a doctor.el file to run their own heuristics
in." in."
:bare t :benchmark nil
(print! "The doctor will see you now...\n") (print! "The doctor will see you now...\n")
;; REVIEW Refactor me ;; REVIEW Refactor me
@ -55,10 +61,10 @@ in."
;; There are 2 newlines between each item to fight against ;; There are 2 newlines between each item to fight against
;; the (fill-region) call in `doom--output-autofill' ;; the (fill-region) call in `doom--output-autofill'
(explain! "Doom supports this version, but you are using a development version of Emacs! " (explain! "Doom supports this version, but you are using a development version of Emacs! "
"Be prepared for possibly weekly breakages that\n\n" "Be prepared for possibly weekly breakages that\n"
"\t- you will have to investigate yourself,\n\n" "\t- you will have to investigate yourself."
"\t- might appear, or be solved, on any Emacs update,\n\n" "\t- might appear, or be solved, on any Emacs update."
"\t- might depend subtly on upstream packages updates\n\n" "\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, " "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.")) "and you should be ready to downgrade Emacs if something is just not fixable."))
(EMACS29+ (EMACS29+
@ -152,9 +158,11 @@ in."
(print! (start "Checking Doom Emacs...")) (print! (start "Checking Doom Emacs..."))
(condition-case-unless-debug ex (condition-case-unless-debug ex
(print-group! (print-group!
(let ((doom-interactive-p 'doctor)) (let ((doom-interactive-p 'doctor)
(doom-initialize 'force) (noninteractive nil))
(doom-initialize-modules)) (defvar doom-reloading-p nil)
(require 'core-start)
(doom-initialize-packages))
(print! (success "Initialized Doom Emacs %s") doom-version) (print! (success "Initialized Doom Emacs %s") doom-version)
(print! (print!
@ -234,8 +242,8 @@ in."
(maphash (lambda (key plist) (maphash (lambda (key plist)
(let (doom-local-errors (let (doom-local-errors
doom-local-warnings) doom-local-warnings)
(let (doom-errors (let (doom-doctor--errors
doom-warnings) doom-doctor--warnings)
(condition-case-unless-debug ex (condition-case-unless-debug ex
(let ((doctor-file (doom-module-path (car key) (cdr key) "doctor.el")) (let ((doctor-file (doom-module-path (car key) (cdr key) "doctor.el"))
(packages-file (doom-module-path (car key) (cdr key) "packages.el"))) (packages-file (doom-module-path (car key) (cdr key) "packages.el")))
@ -247,21 +255,23 @@ in."
unless (or (doom-package-get name :disable) unless (or (doom-package-get name :disable)
(eval (doom-package-get name :ignore)) (eval (doom-package-get name :ignore))
(plist-member (doom-package-get name :recipe) :local-repo) (plist-member (doom-package-get name :recipe) :local-repo)
(doom-package-built-in-p name) (locate-library (symbol-name name))
(doom-package-installed-p name)) ;; (doom-package-built-in-p name)
;; (doom-package-installed-p name)
)
do (print! (error "Missing emacs package: %S") name)) do (print! (error "Missing emacs package: %S") name))
(let ((inhibit-message t)) (let ((inhibit-message t))
(load doctor-file 'noerror 'nomessage))) (load doctor-file 'noerror 'nomessage)))
(file-missing (error! "%s" (error-message-string ex))) (file-missing (error! "%s" (error-message-string ex)))
(error (error! "Syntax error: %s" ex))) (error (error! "Syntax error: %s" ex)))
(when (or doom-errors doom-warnings) (when (or doom-doctor--errors doom-doctor--warnings)
(print-group! (print-group!
(print! (start (bold "%s %s")) (car key) (cdr key)) (print! (start (bold "%s %s")) (car key) (cdr key))
(print! "%s" (string-join (append doom-errors doom-warnings) "\n"))) (print! "%s" (string-join (append doom-doctor--errors doom-doctor--warnings) "\n")))
(setq doom-local-errors doom-errors (setq doom-local-errors doom-doctor--errors
doom-local-warnings doom-warnings))) doom-local-warnings doom-doctor--warnings)))
(appendq! doom-errors doom-local-errors) (appendq! doom-doctor--errors doom-local-errors)
(appendq! doom-warnings doom-local-warnings))) (appendq! doom-doctor--warnings doom-local-warnings)))
doom-modules))) doom-modules)))
(error (error
(warn! "Attempt to load DOOM failed\n %s\n" (warn! "Attempt to load DOOM failed\n %s\n"
@ -269,15 +279,18 @@ in."
(setq doom-modules nil))) (setq doom-modules nil)))
;; Final report ;; Final report
(message "") (terpri)
(dolist (msg (list (list doom-errors "error" 'red) (dolist (msg (list (list doom-doctor--warnings "warning" 'yellow)
(list doom-warnings "warning" 'yellow))) (list doom-doctor--errors "error" 'red)))
(when (car msg) (when (car msg)
(print! (color (nth 2 msg) (print! (color (nth 2 msg)
(if (cdr msg) (if (cdr msg)
"There are %d %ss!" "There are %d %ss!"
"There is %d %s!") "There is %d %s!")
(length (car msg)) (nth 1 msg))))) (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!")) (success! "Everything seems fine, happy Emacs'ing!"))
t) (exit! :pager? "+G"))
(provide 'core-cli-doctor)
;;; doctor.el ends here

217
core/cli/env.el
View file

@ -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 (defcli! env
((allow ["-a" "--allow" regexp] "An additive envvar whitelist regexp") ((allow-only ("--allow-all"))
(reject ["-r" "--reject" regexp] "An additive envvar blacklist regexp") (deny-only ("--deny-all"))
(allow-only ["-A" regexp] "Blacklist everything but REGEXP") (output-file ("-o" path) "Write envvar file to non-standard PATH.")
(reject-only ["-R" regexp] "Whitelist everything but REGEXP") ;; TODO (refresh? ("-r" "--refresh"))
(clear-p ["-c" "--clear"] "Clear and delete your envvar file") &multiple
(outputfile ["-o" path] (rules ("-a" "--allow" "-d" "--deny" regexp) "Allow/deny envvars that match REGEXP"))
"Generate the envvar file at PATH. Envvar files that aren't in "(Re)generates envvars file from your shell environment.
`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.
The envvars file is created by scraping the current shell environment into The envvars file is created by scraping the current shell environment into
newline-delimited KEY=VALUE pairs. Typically by running '$SHELL -ic env' (or 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/) I'd rather it inherit your shell environment /correctly/ (and /completely/)
or not at all. It frontloads the debugging process rather than hiding it or not at all. It frontloads the debugging process rather than hiding it
until you least want to deal with it." until you least want to deal with it."
(let ((env-file (expand-file-name (or outputfile doom-env-file)))) (let ((env-file (doom-path (or output-file doom-env-file))))
(if (null clear-p) (with-temp-file env-file
(doom-cli-reload-env-file (setq-local coding-system-for-write 'utf-8-unix)
'force env-file (print! (start "%s envvars file")
(append (if reject-only (list ".")) (list allow allow-only)) (if (file-exists-p env-file)
(append (if allow-only (list ".")) (list reject reject-only))) "Regenerating"
(unless (file-exists-p env-file) "Generating"))
(user-error! "%S does not exist to be cleared" (path env-file))) (print-group!
(delete-file env-file) (when doom-interactive-p
(print! (success "Successfully deleted %S") (path env-file))))) (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))))
;; (provide 'core-cli-env)
;; Helpers ;;; env.el ends here
(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)))))

542
core/cli/help.el
View file

@ -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") ;;; Variables
(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 ", "))))
(defun doom--cli-print-desc (cli &optional short) (defvar doom-help-commands '("%p %c {-?,--help}")
(print! "%s" "A list of help commands recognized for the running script.
(if short
(car (split-string (doom-cli-desc cli) "\n"))
(doom-cli-desc cli))))
(defun doom--cli-print-short-desc (cli) Recognizes %p (for the prefix) and %c (for the active command).")
(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))
;; ;;
;;; Commands ;;; Commands
(defcli! (help h) (&optional command) (defcli! (:root :help)
"Describe a command or list them all." ((localonly? ("-g" "--no-global") "Hide global options")
:bare t (manpage? ("--manpage") "Generate in manpage format")
(if command (commands? ("--commands") "List all known commands")
(doom--cli-print (doom-cli-get (intern command))) &multiple
(doom--cli-print (doom-cli-get :doom)) (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) (terpri)
(print! (bold "Commands:")) (with-temp-buffer
(print-group! (insert-file-contents (doom-path doom-emacs-dir "LICENSE"))
(dolist (group (seq-group-by (lambda (cli) (re-search-forward "^Copyright (c) ")
(plist-get (doom-cli-plist cli) :group)) (print! "%s\n" (trim (thing-at-point 'line t)))
(cl-loop for name being the hash-keys of doom--cli-commands (print! (p "Doom Emacs uses the MIT license and is provided without warranty "
for cli = (gethash name doom--cli-commands) "of any kind. You may redistribute and modify copies if "
if (and (doom-cli-p cli) "given proper attribution. See the LICENSE file for details.")))))
(not (doom-cli-internal-p cli))
(not (plist-get (doom-cli-plist cli) :hidden)))
collect cli))) ;;
(if (null (car group)) ;;; Helpers
(dolist (cli (cdr group))
(print! "%-16s %s" (defun doom-cli-help (cli)
(doom-cli-name cli) "Return an alist of documentation summarizing CLI (a `doom-cli')."
(car (split-string (doom-cli-desc cli) "\n")))) (let ((docs (doom-cli-docs cli)))
(print! "%-26s %s" `((command . ,(doom-cli-command-string cli))
(bold (concat (car group) ":")) (summary . ,(or (cdr (assoc "SUMMARY" docs)) "TODO"))
(gethash (car group) doom--cli-groups)) (description . ,(or (cdr (assoc "MAIN" docs)) "TODO"))
(print-group! (synopsis . ,(doom-cli-help--synopsis cli))
(dolist (cli (cdr group)) (arguments . ,(doom-cli-help--arguments cli))
(print! "%-16s %s" (options . ,(doom-cli-help--options cli))
(doom-cli-name cli) (commands . ,(doom-cli-subcommands cli 1))
(car (split-string (doom-cli-desc cli) "\n")))))) (sections . ,(seq-filter #'cdr (cddr docs))))))
(terpri)))))
(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

34
core/cli/info.el Normal file
View file

@ -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

106
core/cli/install.el
View file

@ -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) (eval-when-compile (require 'core-cli)) ; appease byte-compiler-sama
((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") ;;; Variables
(nohooks-p ["--no-hooks"] "Don't deploy git hooks"))
;; 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. "Installs and sets up Doom Emacs for the first time.
This command does the following: This command does the following:
1. Creates DOOMDIR at ~/.doom.d, 1. Creates `$DOOMDIR' at ~/.doom.d,
2. Copies ~/.emacs.d/init.example.el to $DOOMDIR/init.el (if it doesn't exist), 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, 3. Creates dummy files for `$DOOMDIR'/{config,packages}.el,
4. Prompts you to generate an envvar file (same as 'doom env'), 4. Prompts you to generate an envvar file (same as `$ doom env`),
5. Installs any dependencies of enabled modules (specified by $DOOMDIR/init.el), 5. Installs any dependencies of enabled modules (specified by `$DOOMDIR'/init.el),
6. And prompts to install all-the-icons' fonts 6. And prompts to install all-the-icons' fonts
This command is idempotent and safe to reuse. This command is idempotent and safe to reuse.
The location of DOOMDIR can be changed with the environment variable of the same Change `$DOOMDIR' with the `--doomdir' option, e.g.
name. e.g.
DOOMDIR=~/.config/doom doom install" ```
$ doom --doomdir /other/doom/config install
```"
(print! (green "Installing Doom Emacs!\n")) (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' ;; Create `doom-private-dir'
(if noconfig-p (if (eq config? :no)
(print! (warn "Not copying private config template, as requested")) (print! (warn "Not copying private config template, as requested"))
;; Create DOOMDIR in ~/.config/doom if ~/.config/emacs exists. ;; Create DOOMDIR in ~/.config/doom if ~/.config/emacs exists.
(when (and (not (file-directory-p doom-private-dir)) (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"))) (let ((xdg-config-dir (or (getenv "XDG_CONFIG_HOME") "~/.config")))
(when (file-in-directory-p doom-emacs-dir xdg-config-dir) (when (file-in-directory-p doom-emacs-dir xdg-config-dir)
(setq doom-private-dir (expand-file-name "doom/" 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) (if (file-directory-p doom-private-dir)
(print-group! (print! (item "Skipping %s (already exists)") (relpath doom-private-dir))
(print! (success "Created %s") (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 ;; Create init.el, config.el & packages.el
(mapc (lambda (file) (print-group!
(cl-destructuring-bind (filename . template) file (mapc (lambda (file)
(if (file-exists-p! filename doom-private-dir) (cl-destructuring-bind (filename . template) file
(print! (warn "%s already exists, skipping") filename) (if (file-exists-p! filename doom-private-dir)
(print! (info "Creating %s%s") (relpath doom-private-dir) filename) (print! (item "Skipping %s (already exists)")
(with-temp-file (doom-path doom-private-dir filename) (path filename))
(insert-file-contents template)) (print! (item "Creating %s%s") (relpath doom-private-dir) filename)
(print! (success "Done!"))))) (with-temp-file (doom-path doom-private-dir filename)
`(("init.el" . ,(doom-path doom-emacs-dir "init.example.el")) (insert-file-contents template))
("config.el" . ,(doom-path doom-core-dir "templates/config.example.el")) (print! (success "Done!")))))
("packages.el" . ,(doom-path doom-core-dir "templates/packages.example.el"))))) `(("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 ;; In case no init.el was present the first time `doom-initialize-modules' was
;; called in core.el (e.g. on first install) ;; called in core.el (e.g. on first install)
(doom-initialize-modules 'force 'no-config) (doom-initialize-modules 'force 'no-config)
;; Ask if user would like an envvar file generated ;; Ask if user would like an envvar file generated
(if noenv-p (if (eq envfile? :no)
(print! (warn "Not generating envvars file, as requested")) (print! (warn "Not generating envvars file, as requested"))
(if (file-exists-p doom-env-file) (if (file-exists-p doom-env-file)
(print! (info "Envvar file already exists, skipping")) (print! (item "Envvar file already exists, skipping"))
(when (or doom-auto-accept (when (or yes? (y-or-n-p "Generate an envvar file? (see `doom help env` for details)"))
(y-or-n-p "Generate an envvar file? (see `doom help env` for details)"))
(doom-cli-reload-env-file 'force-p)))) (doom-cli-reload-env-file 'force-p))))
;; Install Doom packages ;; Install Doom packages
(if noinstall-p (if (eq install? :no)
(print! (warn "Not installing plugins, as requested")) (print! (warn "Not installing plugins, as requested"))
(print! "Installing plugins") (print! "Installing plugins")
(doom-cli-packages-install)) (doom-cli-packages-install))
@ -74,16 +94,16 @@ name. e.g.
(print! "Regenerating autoloads files") (print! "Regenerating autoloads files")
(doom-autoloads-reload) (doom-autoloads-reload)
(if nohooks-p (if (eq hooks? :no)
(print! (warn "Not deploying commit-msg and pre-push git hooks, as requested")) (print! (warn "Not deploying commit-msg and pre-push git hooks, as requested"))
(print! "Deploying commit-msg and pre-push git hooks") (print! "Deploying commit-msg and pre-push git hooks")
(print-group! (print-group!
(condition-case e (condition-case e
(doom-cli--ci-deploy-hooks doom-auto-accept) (doom-cli--ci-deploy-hooks yes?)
('user-error ('user-error
(print! (warn "%s") (error-message-string e)))))) (print! (warn "%s") (error-message-string e))))))
(cond (nofonts-p) (cond ((eq fonts? :no))
(IS-WINDOWS (IS-WINDOWS
(print! (warn "Doom cannot install all-the-icons' fonts on Windows!\n")) (print! (warn "Doom cannot install all-the-icons' fonts on Windows!\n"))
(print-group! (print-group!
@ -93,8 +113,7 @@ name. e.g.
" 2. Execute 'M-x all-the-icons-install-fonts' to download the fonts\n" " 2. Execute 'M-x all-the-icons-install-fonts' to download the fonts\n"
" 3. Open the download location in windows explorer\n" " 3. Open the download location in windows explorer\n"
" 4. Open each font file to install them")))) " 4. Open each font file to install them"))))
((or doom-auto-accept ((or yes? (y-or-n-p "Download and install all-the-icon's fonts?"))
(y-or-n-p "Download and install all-the-icon's fonts?"))
(require 'all-the-icons) (require 'all-the-icons)
(let ((window-system (cond (IS-MAC 'ns) (let ((window-system (cond (IS-MAC 'ns)
(IS-LINUX 'x)))) (IS-LINUX 'x))))
@ -107,3 +126,6 @@ name. e.g.
(with-temp-buffer (with-temp-buffer
(insert-file-contents (doom-path doom-core-dir "templates/QUICKSTART_INTRO")) (insert-file-contents (doom-path doom-core-dir "templates/QUICKSTART_INTRO"))
(print! "%s" (buffer-string))))) (print! "%s" (buffer-string)))))
(provide 'core-cli-install)
;;; install.el ends here

71
core/cli/lib/debugger.el
View file

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

185
core/cli/lib/lib.el
View file

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

129
core/cli/lib/straight-hacks.el
View file

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

418
core/cli/packages.el
View file

@ -1,37 +1,39 @@
;; -*- no-byte-compile: t; -*- ;;; core/cli/packages.el --- package management commands -*- lexical-binding: t; -*-
;;; core/cli/packages.el ;;; Commentary:
;;; Code:
(require 'comp nil t) ;;
;;; Variables
;; None yet!
;; ;;
;;; Commands ;;; Commands
(defcli! (update u) (&rest _) (defcli! (:before (build b purge p)) (&context context)
"This command was removed." (require 'comp nil t)
:hidden t (doom-initialize-core-packages))
(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! (build b) ;; DEPRECATED Replace with "doom sync --rebuild"
((rebuild-p ["-r"] "Only rebuild packages that need rebuilding")) (defcli! ((build b))
((rebuild-p ("-r") "Only rebuild packages that need rebuilding"))
"Byte-compiles & symlinks installed packages. "Byte-compiles & symlinks installed packages.
This ensures that all needed files are symlinked from their package repo and 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 their elisp files are byte-compiled. This is especially necessary if you upgrade
Emacs (as byte-code is generally not forward-compatible)." 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)) (doom-autoloads-reload))
t) t)
(defcli! (purge p) ;; TODO Rename to "doom gc" and move to its own file
((nobuilds-p ["-b" "--no-builds"] "Don't purge unneeded (built) packages") (defcli! ((purge p))
(noelpa-p ["-p" "--no-elpa"] "Don't purge ELPA packages") ((nobuilds-p ("-b" "--no-builds") "Don't purge unneeded (built) packages")
(norepos-p ["-r" "--no-repos"] "Don't purge unused straight repos") (noelpa-p ("-p" "--no-elpa") "Don't purge ELPA packages")
(noeln-p ["-e" "--no-eln"] "Don't purge old ELN bytecode") (norepos-p ("-r" "--no-repos") "Don't purge unused straight repos")
(noregraft-p ["-g" "--no-regraft"] "Regraft git repos (ie. compact them)")) (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. "Deletes orphaned packages & repos, and compacts them.
Purges all installed ELPA packages (as they are considered temporary). Purges 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 It is a good idea to occasionally run this doom purge -g to ensure your package
list remains lean." list remains lean."
(straight-check-all) (straight-check-all)
(when (doom-cli-packages-purge (when (doom-packages-purge
(not noelpa-p) (not noelpa-p)
(not norepos-p) (not norepos-p)
(not nobuilds-p) (not nobuilds-p)
@ -51,24 +53,24 @@ list remains lean."
(doom-autoloads-reload)) (doom-autoloads-reload))
t) t)
;; (defcli! rollback () ; TODO doom rollback (defcli! rollback () :stub t) ; TODO Implement me post-3.0
;; "<Not implemented yet>"
;; (user-error "Not implemented yet, sorry!"))
;; ;;
;;; Library ;;; 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) (and (stringp abbrev-ref)
(stringp ref) (stringp ref)
(string-match-p (concat "^" (regexp-quote abbrev-ref)) (string-match-p (concat "^" (regexp-quote abbrev-ref))
ref))) ref)))
(defun doom--abbrev-commit (commit &optional full) (defun doom-packages--abbrev-commit (commit &optional full)
(if full commit (substring commit 0 7))) (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-with-result
(straight--process-run (straight--process-run
"git" "log" "--oneline" "--no-merges" "git" "log" "--oneline" "--no-merges"
@ -77,7 +79,7 @@ list remains lean."
(string-trim-right (or stdout "")) (string-trim-right (or stdout ""))
(format "ERROR: Couldn't collect commit list because: %s" stderr)))) (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)) (declare (indent 1))
`(let-alist `(let-alist
(let* ((buffer (straight--process-buffer)) (let* ((buffer (straight--process-buffer))
@ -94,12 +96,12 @@ list remains lean."
"\n+\\[Return code: [0-9-]+\\]\n+"))))) "\n+\\[Return code: [0-9-]+\\]\n+")))))
,@body)) ,@body))
(defun doom--barf-if-incomplete-packages () (defun doom-packages--barf-if-incomplete ()
(let ((straight-safe-mode t)) (let ((straight-safe-mode t))
(condition-case _ (straight-check-all) (condition-case _ (straight-check-all)
(error (user-error "Package state is incomplete. Run 'doom sync' first"))))) (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)) (declare (indent 2))
(let ((recipe-var (make-symbol "recipe")) (let ((recipe-var (make-symbol "recipe"))
(recipes-var (make-symbol "recipes"))) (recipes-var (make-symbol "recipes")))
@ -114,14 +116,14 @@ list remains lean."
,(doom-enlist binds) ,(doom-enlist binds)
,@body)))))) ,@body))))))
(defvar doom--cli-updated-recipes nil) (defvar doom-packages--cli-updated-recipes nil)
(defun doom--cli-recipes-update () (defun doom-packages--cli-recipes-update ()
"Updates straight and recipe repos." "Updates straight and recipe repos."
(unless doom--cli-updated-recipes (unless doom-packages--cli-updated-recipes
(straight--make-build-cache-available) (straight--make-build-cache-available)
(print! (start "Updating recipe repos...")) (print! (start "Updating recipe repos..."))
(print-group! (print-group!
(doom--with-package-recipes (doom-packages--with-recipes
(delq (delq
nil (mapcar (doom-rpartial #'gethash straight--repo-cache) nil (mapcar (doom-rpartial #'gethash straight--repo-cache)
(mapcar #'symbol-name straight-recipe-repositories))) (mapcar #'symbol-name straight-recipe-repositories)))
@ -130,39 +132,39 @@ list remains lean."
(ref (straight-vc-get-commit type local-repo)) (ref (straight-vc-get-commit type local-repo))
newref output) newref output)
(print! (start "\033[KUpdating recipes for %s...%s") package esc) (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 (when .it
(setq output .output) (setq output .output)
(straight-merge-package package) (straight-merge-package package)
(unless (equal ref (setq newref (straight-vc-get-commit type local-repo))) (unless (equal ref (setq newref (straight-vc-get-commit type local-repo)))
(print! (success "\033[K%s updated (%s -> %s)") (print! (success "\033[K%s updated (%s -> %s)")
package package
(doom--abbrev-commit ref) (doom-packages--abbrev-commit ref)
(doom--abbrev-commit newref)) (doom-packages--abbrev-commit newref))
(unless (string-empty-p output) (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) (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'." "Return the short .eln file name corresponding to `file'."
(concat comp-native-version-dir "/" (concat comp-native-version-dir "/"
(file-name-nondirectory (file-name-nondirectory
(comp-el-to-eln-filename file)))) (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'." "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'." "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'." "Find `eln-name' on the `native-comp-eln-load-path'."
(cl-some (lambda (eln-path) (cl-some (lambda (eln-path)
(let ((file (concat eln-path eln-name))) (let ((file (concat eln-path eln-name)))
@ -170,7 +172,7 @@ list remains lean."
file))) file)))
native-comp-eln-load-path)) 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." "Check whether the corresponding .elc for `file' is outdated."
(let ((elc-file (byte-compile-dest-file file))) (let ((elc-file (byte-compile-dest-file file)))
;; NOTE Ignore missing elc files, they could be missing due to ;; 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) (doom-log "%s is newer than %s" file elc-file)
t))) 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." "Check whether the corresponding .eln for `file' is outdated."
(let* ((eln-name (doom--eln-file-name file)) (let* ((eln-name (doom-packages--eln-file-name file))
(eln-file (doom--find-eln-file eln-name)) (eln-file (doom-packages--find-eln-file eln-name))
(error-file (doom--eln-error-file eln-name))) (error-file (doom-packages--eln-error-file eln-name)))
(cond (eln-file (cond (eln-file
(when (file-newer-than-file-p file eln-file) (when (file-newer-than-file-p file eln-file)
(doom-log "%s is newer than %s" 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) (doom-log "%s doesn't exist" eln-name)
t)))) 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." "Callback fired when an item has finished async compilation."
(when file (when file
(let* ((eln-name (doom--eln-file-name file)) (let* ((eln-name (doom-packages--eln-file-name file))
(eln-file (doom--eln-output-file eln-name)) (eln-file (doom-packages--eln-output-file eln-name))
(error-file (doom--eln-error-file eln-name))) (error-file (doom-packages--eln-error-file eln-name)))
(if (file-exists-p eln-file) (if (file-exists-p eln-file)
(doom-log "Compiled %s" eln-file) (doom-log "Compiled %s" eln-file)
(make-directory (file-name-directory error-file) 'parents) (make-directory (file-name-directory error-file) 'parents)
(write-region "" nil error-file) (write-region "" nil error-file)
(doom-log "Wrote %s" 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." "How many async native compilation jobs are queued or in-progress."
(if (featurep 'comp) (if (featurep 'comp)
(+ (length comp-files-queue) (+ (length comp-files-queue)
(comp-async-runnings)) (comp-async-runnings))
0)) 0))
(defun doom--wait-for-native-compile-jobs () (defun doom-packages--wait-for-native-compile-jobs ()
"Wait for all pending async native compilation 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 with previous = 0
while (not (zerop pending)) while (not (zerop pending))
if (/= previous pending) do if (/= previous pending) do
@ -228,21 +230,21 @@ list remains lean."
(let ((inhibit-message t)) (let ((inhibit-message t))
(sleep-for 0.1)))) (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." "Write .error files for any expected .eln files that are missing."
(when NATIVECOMP (when NATIVECOMP
(cl-loop for file in doom--eln-output-expected (cl-loop for file in doom-packages--eln-output-expected
for eln-name = (doom--eln-file-name file) for eln-name = (doom-packages--eln-file-name file)
for eln-file = (doom--eln-output-file eln-name) for eln-file = (doom-packages--eln-output-file eln-name)
for error-file = (doom--eln-error-file eln-name) for error-file = (doom-packages--eln-error-file eln-name)
unless (or (file-exists-p eln-file) unless (or (file-exists-p eln-file)
(file-newer-than-file-p error-file file)) (file-newer-than-file-p error-file file))
do (make-directory (file-name-directory error-file) 'parents) do (make-directory (file-name-directory error-file) 'parents)
(write-region "" nil error-file) (write-region "" nil error-file)
(doom-log "Wrote %s" 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." "Queue async compilation for all non-doom Elisp files."
(when NATIVECOMP (when NATIVECOMP
(cl-loop with paths = (cl-loop for path in load-path (cl-loop with paths = (cl-loop for path in load-path
@ -250,14 +252,14 @@ list remains lean."
collect path) collect path)
for file in (doom-files-in paths :match "\\.el\\(?:\\.gz\\)?$") for file in (doom-files-in paths :match "\\.el\\(?:\\.gz\\)?$")
if (and (file-exists-p (byte-compile-dest-file file)) 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) (not (cl-some (lambda (re)
(string-match-p re file)) (string-match-p re file))
native-comp-deferred-compilation-deny-list))) do native-comp-deferred-compilation-deny-list))) do
(doom-log "Compiling %s" file) (doom-log "Compiling %s" file)
(native-compile-async file)))) (native-compile-async file))))
(defun doom-cli-packages-install () (defun doom-packages-install ()
"Installs missing packages. "Installs missing packages.
This function will install any primary package (i.e. a package with a `package!' 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...")) (print! (start "Installing packages..."))
(let ((pinned (doom-package-pinned-list))) (let ((pinned (doom-package-pinned-list)))
(print-group! (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 (if-let (built
(doom--with-package-recipes (doom-package-recipe-list) (doom-packages--with-recipes (doom-package-recipe-list)
(recipe package type local-repo) (recipe package type local-repo)
(unless (file-directory-p (straight--repos-dir 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 (condition-case-unless-debug e
(let ((straight-use-package-pre-build-functions (let ((straight-use-package-pre-build-functions
(cons (lambda (pkg &rest _) (cons (lambda (pkg &rest _)
(when-let (commit (cdr (assoc pkg pinned))) (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-pre-build-functions)))
(straight-use-package (intern package)) (straight-use-package (intern package))
;; HACK Line encoding issues can plague repos with dirty ;; HACK Line encoding issues can plague repos with dirty
@ -291,16 +293,16 @@ declaration) or dependency thereof that hasn't already been."
(error (error
(signal 'doom-package-error (list package e)))))) (signal 'doom-package-error (list package e))))))
(progn (progn
(doom--compile-site-packages) (doom-packages--compile-site-files)
(when NATIVECOMP (when NATIVECOMP
(doom--wait-for-native-compile-jobs) (doom-packages--wait-for-native-compile-jobs)
(doom--write-missing-eln-errors)) (doom-packages--write-missing-eln-errors))
(print! (success "\033[KInstalled %d packages") (length built))) (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)))) nil))))
(defun doom-cli-packages-build (&optional force-p) (defun doom-packages-build (&optional force-p)
"(Re)build all packages." "(Re)build all packages."
(doom-initialize-packages) (doom-initialize-packages)
(print! (start "(Re)building %spackages...") (if force-p "all " "")) (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) (or (if force-p :all straight--packages-to-rebuild)
(make-hash-table :test #'equal))) (make-hash-table :test #'equal)))
(recipes (doom-package-recipe-list))) (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 (unless force-p
(straight--make-build-cache-available)) (straight--make-build-cache-available))
(if-let (built (if-let (built
(doom--with-package-recipes recipes (package local-repo recipe) (doom-packages--with-recipes recipes (package local-repo recipe)
(unless force-p (unless force-p
;; Ensure packages with outdated files/bytecode are rebuilt ;; Ensure packages with outdated files/bytecode are rebuilt
(let* ((build-dir (straight--build-dir package)) (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))) (file-exists-p (straight--modified-dir (or local-repo package)))
(cl-loop with outdated = nil (cl-loop with outdated = nil
for file in (doom-files-in build-dir :match "\\.el$" :full t) 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 (or (if want-byte-compile (doom-packages--elc-file-outdated-p file))
(if want-native-compile (doom--eln-file-outdated-p file))) (if want-native-compile (doom-packages--eln-file-outdated-p file)))
do (setq outdated t) do (setq outdated t)
(when want-native-compile (when want-native-compile
(push file doom--eln-output-expected)) (push file doom-packages--eln-output-expected))
finally return outdated)) finally return outdated))
(puthash package t straight--packages-to-rebuild)))) (puthash package t straight--packages-to-rebuild))))
(straight-use-package (intern package)))) (straight-use-package (intern package))))
(progn (progn
(doom--compile-site-packages) (doom-packages--compile-site-files)
(when NATIVECOMP (when NATIVECOMP
(doom--wait-for-native-compile-jobs) (doom-packages--wait-for-native-compile-jobs)
(doom--write-missing-eln-errors)) (doom-packages--write-missing-eln-errors))
;; HACK Every time you save a file in a package that straight tracks, ;; HACK Every time you save a file in a package that straight tracks,
;; it is recorded in ~/.emacs.d/.local/straight/modified/. ;; it is recorded in ~/.emacs.d/.local/straight/modified/.
;; Typically, straight will clean these up after rebuilding, but ;; 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: ;; sync' or similar is run, so we clean it up ourselves:
(delete-directory (straight--modified-dir) 'recursive) (delete-directory (straight--modified-dir) 'recursive)
(print! (success "\033[KRebuilt %d package(s)") (length built))) (print! (success "\033[KRebuilt %d package(s)") (length built)))
(print! (info "No packages need rebuilding")) (print! (item "No packages need rebuilding"))
nil)))) nil))))
(defun doom-cli-packages-update () (defun doom-packages-update ()
"Updates packages." "Updates packages."
(doom-initialize-packages) (doom-initialize-packages)
(doom--barf-if-incomplete-packages) (doom-packages--barf-if-incomplete)
(doom--cli-recipes-update) (doom-packages--cli-recipes-update)
(let* ((repo-dir (straight--repos-dir)) (let* ((repo-dir (straight--repos-dir))
(pinned (doom-package-pinned-list)) (pinned (doom-package-pinned-list))
(recipes (doom-package-recipe-list)) (recipes (doom-package-recipe-list))
@ -387,7 +389,7 @@ declaration) or dependency thereof that hasn't already been."
(i 0) (i 0)
errors) errors)
(print! (start "Updating packages (this may take a while)...")) (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) (cl-incf i)
(print-group! (print-group!
(unless (straight--repository-is-available-p recipe) (unless (straight--repository-is-available-p recipe)
@ -414,30 +416,37 @@ declaration) or dependency thereof that hasn't already been."
(or (cond (or (cond
((not (stringp target-ref)) ((not (stringp target-ref))
(print! (start "\033[K(%d/%d) Fetching %s...%s") i total package esc) (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 (when .it
(straight-merge-package package) (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 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))) 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))))) (cl-return)))))
((doom--same-commit-p target-ref ref) ((doom-packages--same-commit-p target-ref ref)
(print! (info "\033[K(%d/%d) %s is up-to-date...%s") i total package esc) (print! (item "\033[K(%d/%d) %s is up-to-date...%s") i total package esc)
(cl-return)) (cl-return))
((if (straight-vc-commit-present-p recipe target-ref) ((if (straight-vc-commit-present-p recipe target-ref)
(print! (start "\033[K(%d/%d) Checking out %s (%s)...%s") (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) (print! (start "\033[K(%d/%d) Fetching %s...%s") i total package esc)
(and (straight-vc-fetch-from-remote recipe) (and (straight-vc-fetch-from-remote recipe)
(straight-vc-commit-present-p recipe target-ref))) (straight-vc-commit-present-p recipe target-ref)))
(straight-vc-check-out-commit recipe target-ref) (straight-vc-check-out-commit recipe target-ref)
(or (not (eq type 'git)) (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)))) 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) ((print! (start "\033[K(%d/%d) Re-cloning %s...") i total local-repo esc)
(let ((repo (straight--repos-dir local-repo)) (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)) (straight-use-package (intern package) nil 'no-build))
(prog1 (file-directory-p repo) (prog1 (file-directory-p repo)
(or (not (eq type 'git)) (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)))))))) commits (length (split-string output "\n" t))))))))
(progn (progn
(print! (warn "\033[K(%d/%d) Failed to fetch %s") (print! (warn "\033[K(%d/%d) Failed to fetch %s")
i total local-repo) i total local-repo)
(unless (string-empty-p output) (unless (string-empty-p output)
(print-group! (print! (info "%s" output)))) (print-group! (print! (item "%s" output))))
(cl-return))) (cl-return)))
(puthash local-repo t repos-to-rebuild) (puthash local-repo t repos-to-rebuild)
(puthash package t packages-to-rebuild) (puthash package t packages-to-rebuild)
(print! (success "\033[K(%d/%d) %s: %s -> %s%s") (print! (success "\033[K(%d/%d) %s: %s -> %s%s")
i total local-repo i total local-repo
(doom--abbrev-commit ref) (doom-packages--abbrev-commit ref)
(doom--abbrev-commit target-ref) (doom-packages--abbrev-commit target-ref)
(if (and (integerp commits) (> commits 0)) (if (and (integerp commits) (> commits 0))
(format " [%d commit(s)]" commits) (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") (concat (string-join (cl-subseq (butlast lines 1) 0 20) "\n")
"\n[...]") "\n[...]")
output))) output)))
(print-group! (print! "%s" (indent 2 output))))) (print-group! (print! "%s" (indent output 2)))))
(user-error (user-error
(signal 'user-error (error-message-string e))) (signal 'user-error (error-message-string e)))
(error (error
@ -486,12 +495,12 @@ declaration) or dependency thereof that hasn't already been."
(hash-table-keys packages-to-rebuild))) (hash-table-keys packages-to-rebuild)))
(print! (success "Updated %d package(s)") (print! (success "Updated %d package(s)")
(hash-table-count packages-to-rebuild)) (hash-table-count packages-to-rebuild))
(doom-cli-packages-build) (doom-packages-build)
t)))) t))))
;;; PURGE (for the emperor) ;;; PURGE (for the emperor)
(defun doom--cli-packages-purge-build (build) (defun doom-packages--purge-build (build)
(let ((build-dir (straight--build-dir build))) (let ((build-dir (straight--build-dir build)))
(delete-directory build-dir 'recursive) (delete-directory build-dir 'recursive)
(if (file-directory-p build-dir) (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)) (print! (success "Purged build/%s" build))
t))) t)))
(defun doom--cli-packages-purge-builds (builds) (defun doom-packages--purge-builds (builds)
(if (not builds) (if (not builds)
(prog1 0 (prog1 0
(print! (info "No builds to purge"))) (print! (item "No builds to purge")))
(print! (start "Purging straight builds..." (length builds))) (print! (start "Purging straight builds..." (length builds)))
(print-group! (print-group!
(length (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 (unless repo
(error "No repo specified for regrafting")) (error "No repo specified for regrafting"))
(let ((default-directory (straight--repos-dir repo))) (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" "reset" "--hard")
(doom-call-process "git" "clean" "-ffd") (doom-call-process "git" "clean" "-ffd")
(if (not (zerop (car (doom-call-process "git" "replace" "--graft" "HEAD")))) (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" "reflog" "expire" "--expire=all" "--all")
(doom-call-process "git" "gc" "--prune=now") (doom-call-process "git" "gc" "--prune=now")
(let ((after-size (doom-directory-size default-directory))) (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))))) repo before-size after-size)))))
t)) t))
(defun doom--cli-packages-regraft-repos (repos) (defun doom-packages--regraft-repos (repos)
(if (not repos) (if (not repos)
(prog1 0 (prog1 0
(print! (info "No repos to regraft"))) (print! (item "No repos to regraft")))
(print! (start "Regrafting %d repos..." (length repos))) (print! (start "Regrafting %d repos..." (length repos)))
(let ((before-size (doom-directory-size (straight--repos-dir)))) (let ((before-size (doom-directory-size (straight--repos-dir))))
(print-group! (print-group!
(prog1 (delq nil (mapcar #'doom--cli-packages-regraft-repo repos)) (prog1 (delq nil (mapcar #'doom-packages--regraft-repo repos))
(princ "\033[K") (princ "\033[K")
(let ((after-size (doom-directory-size (straight--repos-dir)))) (let ((after-size (doom-directory-size (straight--repos-dir))))
(print! (success "Finished regrafting. Size before: %0.1fKB and after: %0.1fKB (%0.1fKB)") (print! (success "Finished regrafting. Size before: %0.1fKB and after: %0.1fKB (%0.1fKB)")
before-size after-size before-size after-size
(- after-size before-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))) (let ((repo-dir (straight--repos-dir repo)))
(when (file-directory-p repo-dir) (when (file-directory-p repo-dir)
(delete-directory repo-dir 'recursive) (delete-directory repo-dir 'recursive)
@ -556,21 +565,21 @@ declaration) or dependency thereof that hasn't already been."
(print! (success "Purged repos/%s" repo)) (print! (success "Purged repos/%s" repo))
t)))) t))))
(defun doom--cli-packages-purge-repos (repos) (defun doom-packages--purge-repos (repos)
(if (not repos) (if (not repos)
(prog1 0 (prog1 0
(print! (info "No repos to purge"))) (print! (item "No repos to purge")))
(print! (start "Purging straight repositories...")) (print! (start "Purging straight repositories..."))
(print-group! (print-group!
(length (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) (require 'core-packages)
(let ((dirs (doom-files-in package-user-dir :type t :depth 0))) (let ((dirs (doom-files-in package-user-dir :type t :depth 0)))
(if (not dirs) (if (not dirs)
(prog1 0 (prog1 0
(print! (info "No ELPA packages to purge"))) (print! (item "No ELPA packages to purge")))
(print! (start "Purging ELPA packages...")) (print! (start "Purging ELPA packages..."))
(dolist (path dirs (length dirs)) (dolist (path dirs (length dirs))
(condition-case e (condition-case e
@ -584,23 +593,23 @@ declaration) or dependency thereof that hasn't already been."
(filename path) (filename path)
e))))))) e)))))))
(defun doom--cli-packages-purge-eln () (defun doom-packages--purge-eln ()
(if-let (dirs (if-let (dirs
(cl-delete (expand-file-name comp-native-version-dir doom--eln-output-path) (cl-delete (expand-file-name comp-native-version-dir doom-packages--eln-output-path)
(directory-files doom--eln-output-path t "^[^.]" t) (directory-files doom-packages--eln-output-path t "^[^.]" t)
:test #'file-equal-p)) :test #'file-equal-p))
(progn (progn
(print! (start "Purging old native bytecode...")) (print! (start "Purging old native bytecode..."))
(print-group! (print-group!
(dolist (dir dirs) (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)) (delete-directory dir 'recursive))
(print! (success "Purged %d directory(ies)" (length dirs)))) (print! (success "Purged %d directory(ies)" (length dirs))))
(length dirs)) (length dirs))
(print! (info "No ELN directories to purge")) (print! (item "No ELN directories to purge"))
0)) 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. "Auto-removes orphaned packages and repos.
An orphaned package is a package that isn't a primary package (i.e. doesn't have 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 REPOS-P, include straight repos.
If ELPA-P, include packages installed with package.el (M-x package-install)." If ELPA-P, include packages installed with package.el (M-x package-install)."
(doom-initialize-packages) (doom-initialize-packages)
(doom--barf-if-incomplete-packages) (doom-packages--barf-if-incomplete)
(print! (start "Purging orphaned packages (for the emperor)...")) (print! (start "Purging orphaned packages (for the emperor)..."))
(cl-destructuring-bind (&optional builds-to-purge repos-to-purge repos-to-regraft) (cl-destructuring-bind (&optional builds-to-purge repos-to-purge repos-to-regraft)
(let ((rdirs (let ((rdirs
@ -631,19 +640,158 @@ If ELPA-P, include packages installed with package.el (M-x package-install)."
(delq (delq
nil (list nil (list
(if (not builds-p) (if (not builds-p)
(ignore (print! (info "Skipping builds"))) (ignore (print! (item "Skipping builds")))
(and (/= 0 (doom--cli-packages-purge-builds builds-to-purge)) (and (/= 0 (doom-packages--purge-builds builds-to-purge))
(straight-prune-build-cache))) (straight-prune-build-cache)))
(if (not elpa-p) (if (not elpa-p)
(ignore (print! (info "Skipping elpa packages"))) (ignore (print! (item "Skipping elpa packages")))
(/= 0 (doom--cli-packages-purge-elpa))) (/= 0 (doom-packages--purge-elpa)))
(if (not repos-p) (if (not repos-p)
(ignore (print! (info "Skipping repos"))) (ignore (print! (item "Skipping repos")))
(/= 0 (doom--cli-packages-purge-repos repos-to-purge))) (/= 0 (doom-packages--purge-repos repos-to-purge)))
(if (not regraft-repos-p) (if (not regraft-repos-p)
(ignore (print! (info "Skipping regrafting"))) (ignore (print! (item "Skipping regrafting")))
(doom--cli-packages-regraft-repos repos-to-regraft)) (doom-packages--regraft-repos repos-to-regraft))
(when NATIVECOMP (when NATIVECOMP
(if (not eln-p) (if (not eln-p)
(ignore (print! (info "Skipping native bytecode"))) (ignore (print! (item "Skipping native bytecode")))
(doom--cli-packages-purge-eln)))))))) (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

103
core/cli/run.el Normal file
View file

@ -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

77
core/cli/sync.el
View file

@ -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) (load! "packages")
((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")) ;;; 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. "Synchronize your config with Doom Emacs.
This is the equivalent of running autoremove, install, autoloads, then 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 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 installed, autoloads files are up-to-date and no byte-compiled files have gone
stale." stale."
(run-hooks 'doom-sync-pre-hook) :benchmark t
(add-hook 'kill-emacs-hook #'doom--cli-abort-warning-h) (run-hooks 'doom-before-sync-hook)
(add-hook 'kill-emacs-hook #'doom-sync--abort-warning-h)
(print! (start "Synchronizing your config with Doom Emacs...")) (print! (start "Synchronizing your config with Doom Emacs..."))
(unwind-protect (unwind-protect
(print-group! (print-group!
(delete-file doom-autoloads-file) (when (and (not noenvvar?)
(when (and (not no-envvar-p)
(file-exists-p doom-env-file)) (file-exists-p doom-env-file))
(doom-cli-reload-env-file 'force)) (doom-cli-call '("doom" "env")))
(doom-cli-packages-install) (doom-packages-install)
(doom-cli-packages-build) (doom-packages-build)
(when update-p (when update?
(doom-cli-packages-update)) (doom-packages-update))
(doom-cli-packages-purge purge-p 'builds-p purge-p purge-p purge-p) (doom-packages-purge purge? 'builds-p purge? purge? purge?)
(run-hooks 'doom-sync-post-hook) (run-hooks 'doom-after-sync-hook)
(when (doom-autoloads-reload) (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) t)
(remove-hook 'kill-emacs-hook #'doom--cli-abort-warning-h))) (remove-hook 'kill-emacs-hook #'doom-sync--abort-warning-h)))
;; DEPRECATED Remove when v3.0 is released
;; (defobsolete! ((refresh re)) "doom sync" "v3.0.0")
;;; DEPRECATED Commands
(defcli! (refresh re) ()
"Deprecated for 'doom sync'"
:hidden t
(user-error "'doom refresh' has been replaced with 'doom sync'. Use that instead"))
;; ;;
;;; Helpers ;;; Helpers
(defun doom--cli-abort-warning-h () (defun doom-sync--abort-warning-h ()
(terpri) (print! (warn "Script was abruptly aborted, leaving Doom in an incomplete state!"))
(print! (warn "Script was abruptly aborted! Run 'doom sync' to repair inconsistencies"))) (print! (item "Run 'doom sync' to repair it.")))
(provide 'core-cli-sync)
;;; sync.el ends here

40
core/cli/test.el
View file

@ -1,16 +1,20 @@
;;; core/cli/test.el -*- lexical-binding: t; -*- ;;; core/cli/test.el -*- lexical-binding: t; -*-
;;; Commentary:
;;; Code:
(defun doom--emacs-binary () ;;
(let ((emacs-binary-path (doom-path invocation-directory invocation-name)) ;;; Variables
(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)))
;; None yet!
;;
;;; Commands
(defcli! test (&rest targets) (defcli! test (&rest targets)
"Run Doom unit tests." "Run Doom unit tests."
:bare t :disable t
;; FIXME Tests don't work; will be fixed in v3.1
(doom-initialize 'force 'noerror) (doom-initialize 'force 'noerror)
(require 'ansi-color) (require 'ansi-color)
(let (files read-files) (let (files read-files)
@ -39,13 +43,12 @@
(print! (start "Bootstrapping test environment, if necessary...")) (print! (start "Bootstrapping test environment, if necessary..."))
(cl-destructuring-bind (status . output) (cl-destructuring-bind (status . output)
(doom-exec-process (doom-exec-process
(doom--emacs-binary) (doom-test--emacs-binary)
"--batch" "--batch"
"--eval" "--eval"
(prin1-to-string (prin1-to-string
`(progn `(progn
(setq user-emacs-directory ,doom-emacs-dir (setq user-emacs-directory ,doom-emacs-dir)
doom-auto-accept t)
(require 'core ,(locate-library "core")) (require 'core ,(locate-library "core"))
(require 'core-cli) (require 'core-cli)
(doom-initialize 'force 'noerror) (doom-initialize 'force 'noerror)
@ -60,7 +63,7 @@
(if (doom-file-cookie-p file "if" t) (if (doom-file-cookie-p file "if" t)
(cl-destructuring-bind (_status . output) (cl-destructuring-bind (_status . output)
(apply #'doom-exec-process (apply #'doom-exec-process
(doom--emacs-binary) (doom-test--emacs-binary)
"--batch" "--batch"
"-l" (concat doom-core-dir "core.el") "-l" (concat doom-core-dir "core.el")
"-l" (concat doom-core-dir "test/helpers.el") "-l" (concat doom-core-dir "test/helpers.el")
@ -70,7 +73,7 @@
"-f" "buttercup-run"))) "-f" "buttercup-run")))
(insert (replace-regexp-in-string ansi-color-control-seq-regexp "" output)) (insert (replace-regexp-in-string ansi-color-control-seq-regexp "" output))
(push file read-files)) (push file read-files))
(print! (info "Ignoring %s" (relpath file))))) (print! (item "Ignoring %s" (relpath file)))))
(let ((total 0) (let ((total 0)
(total-failed 0) (total-failed 0)
(i 0)) (i 0))
@ -102,3 +105,16 @@
(print! (error "Ran %d tests, %d failed") total total-failed) (print! (error "Ran %d tests, %d failed") total total-failed)
(kill-emacs 1))) (kill-emacs 1)))
t))) 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

131
core/cli/upgrade.el
View file

@ -1,8 +1,26 @@
;;; core/cli/upgrade.el -*- lexical-binding: t; -*- ;;; core/cli/upgrade.el -*- lexical-binding: t; -*-
;;; Commentary:
;;; Code:
(defcli! (upgrade up) (load! "packages")
((force-p ["-f" "--force"] "Discard local changes to Doom and packages, and upgrade anyway")
(packages-only-p ["-p" "--packages"] "Only upgrade packages, not Doom"))
;;
;;; 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. "Updates Doom and packages.
This requires that ~/.emacs.d is a git repo, and is the equivalent of the 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 cd ~/.emacs.d
git pull --rebase git pull --rebase
bin/doom clean doom clean
bin/doom sync -u" doom sync -u"
:bare t (let* ((force? (doom-cli-context-suppress-prompts-p context))
(let ((doom-auto-discard force-p)) (sync-cmd `("doom" "sync" "-u")))
(cond (cond
(packages-only-p (packages-only?
(doom-cli-execute "sync" "-u") (doom-cli-call sync-cmd)
(print! (success "Finished upgrading Doom Emacs"))) (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. ;; Reload Doom's CLI & libraries, in case there were any upstream changes.
;; Major changes will still break, however ;; Major changes will still break, however
(print! (info "Reloading Doom Emacs")) (print! (item "Reloading Doom Emacs"))
(throw 'exit (list "doom" "upgrade" "-p" (if force-p "-f")))) (exit! "doom" "upgrade" "-p" (if force? "--force")))
((print! "Doom is up-to-date!") ((print! "Doom is up-to-date!")
(doom-cli-execute "sync" "-u"))))) (doom-cli-call sync-cmd)))))
;; ;;
;;; library ;;; Helpers
(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))))))
(defun doom-cli-upgrade (&optional auto-accept-p force-p) (defun doom-cli-upgrade (&optional auto-accept-p force-p)
"Upgrade Doom to the latest version non-destructively." "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")))) (cdr (doom-call-process "git" "name-rev" "--name-only" "HEAD"))))
(target-remote (format "%s_%s" doom-repo-remote branch))) (target-remote (format "%s_%s" doom-repo-remote branch)))
(unless branch (unless branch
(error! (if (file-exists-p! ".git" doom-emacs-dir) (error (if (file-exists-p! ".git" doom-emacs-dir)
"Couldn't find Doom's .git directory. Was Doom cloned properly?" "Couldn't find Doom's .git directory. Was Doom cloned properly?"
"Couldn't detect what branch you're on. Is Doom detached?"))) "Couldn't detect what branch you're on. Is Doom detached?")))
;; We assume that a dirty .emacs.d is intentional and abort ;; 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) (if (not force-p)
(user-error! "%s\n\n%s\n\n %s" (user-error "%s\n\n%s\n\n %s"
(format "Refusing to upgrade because %S has been modified." (path doom-emacs-dir)) (format "Refusing to upgrade because %S has been modified."
"Either stash/undo your changes or run 'doom upgrade -f' to discard local changes." (abbreviate-file-name doom-emacs-dir))
(string-join dirty "\n")) "Either stash/undo your changes or run 'doom upgrade -f' to discard local changes."
(print! (info "You have local modifications in Doom's source. Discarding them...")) (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" "reset" "--hard" (format "origin/%s" branch))
(doom-call-process "git" "clean" "-ffd"))) (doom-call-process "git" "clean" "-ffd")))
@ -104,7 +100,7 @@ following shell commands:
(print! (success "Doom is already up-to-date!")) (print! (success "Doom is already up-to-date!"))
nil) 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) (substring this-rev 0 10)
(cdr (doom-call-process "git" "log" "-1" "--format=%cr" "HEAD")) (cdr (doom-call-process "git" "log" "-1" "--format=%cr" "HEAD"))
(substring new-rev 0 10) (substring new-rev 0 10)
@ -117,7 +113,7 @@ following shell commands:
(print! "Link to diff: %s" diff-url) (print! "Link to diff: %s" diff-url)
(when (and (not auto-accept-p) (when (and (not auto-accept-p)
(y-or-n-p "View the comparison diff in your browser?")) (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))) (browse-url diff-url)))
(if (not (or auto-accept-p (if (not (or auto-accept-p
@ -126,24 +122,43 @@ following shell commands:
(print! (start "Upgrading Doom Emacs...")) (print! (start "Upgrading Doom Emacs..."))
(print-group! (print-group!
(doom-clean-byte-compiled-files) (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))) (or (and (zerop (car (doom-call-process "git" "reset" "--hard" target-remote)))
(equal (cdr (doom-call-process "git" "rev-parse" "HEAD")) new-rev)) (equal (cdr (doom-call-process "git" "rev-parse" "HEAD")) new-rev))
(error "Failed to check out %s" (substring new-rev 0 10))) (error "Failed to check out %s" (substring new-rev 0 10)))
;; HACK It's messy to use straight to upgrade straight, due ;; HACK It's messy to use straight to upgrade straight, due
;; to the potential for backwards incompatibility, so ;; to the potential for backwards incompatibility, so we
;; we staticly check if Doom's `package!' declaration ;; staticly check if Doom's `package!' declaration for
;; for straight has changed. If it has, delete ;; straight has changed. If it has, delete straight so
;; straight so 'doom upgrade's second stage will ;; 'doom upgrade's second stage will install the new
;; install the new version for us. ;; version for us.
;; ;;
;; Clumsy, but a better solution is in the works. ;; Clumsy, but a better solution is in the works.
(unless (equal straight-recipe (doom--get-straight-recipe)) (unless (equal straight-recipe (doom-upgrade--get-straight-recipe))
(print! (info "Preparing straight for an update")) (print! (item "Preparing straight for an update"))
(delete-directory (doom-path straight-base-dir "straight/repos/straight.el") (delete-directory (doom-path straight-base-dir "straight/repos/straight.el")
'recursive))) 'recursive)))
(print! (info "%s") (cdr result)) (print! (item "%s") (cdr result))
t)))))) t))))))
(ignore-errors (ignore-errors
(doom-call-process "git" "branch" "-D" target-remote) (doom-call-process "git" "branch" "-D" target-remote)
(doom-call-process "git" "remote" "remove" doom-repo-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

1724
core/core-cli-lib.el Normal file
View file

File diff suppressed because it is too large Load diff

342
core/core-cli.el
View file

@ -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") (when (version< emacs-version "27.1")
"If non-nil, Doom will auto-accept any confirmation prompts during batch (message
commands like `doom-cli-packages-install', `doom-cli-packages-update' and (concat
`doom-packages-autoremove'.") "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 (defvar doom-cli--dump (getenv "__DOOMDUMP")
additional CLI commands, or reconfigure existing ones to better suit their "If non-nil, dump target CLIs to stdout (or all of `doom-cli--table').
purpose.")
(defvar doom-cli-log-file (concat doom-local-dir "doom.log") This exists so external tools or Doom binscripts can inspect each other.")
"Where to write the extended output to.")
(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)) ;;; Setup CLI session
(defvar doom--cli-groups (make-hash-table :test 'equal))
(defvar doom--cli-group nil)
(define-error 'doom-cli-error "There was an unexpected error" 'doom-error) ;; The garbage collector isn't so important during CLI ops. A higher threshold
(define-error 'doom-cli-command-not-found-error "Could not find that command" 'doom-cli-error) ;; makes it 15-30% faster, but set it too high and we risk runaway memory usage
(define-error 'doom-cli-wrong-number-of-arguments-error "Wrong number of CLI arguments" 'doom-cli-error) ;; in longer sessions.
(define-error 'doom-cli-unrecognized-option-error "Not a recognized option" 'doom-cli-error) (setq gc-cons-threshold 134217728) ; 128mb
(define-error 'doom-cli-deprecated-error "Command is deprecated" 'doom-cli-error)
;; 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 ;;; Bootstrap
(require 'seq) ;; Our DSL, API, and everything nice.
(load! "autoload/process") (require 'core-cli-lib)
(load! "autoload/system")
(load! "autoload/plist")
(load! "autoload/files")
(load! "autoload/output")
(load! "cli/lib/debugger") ;; Use our own home-grown debugger so we can capture backtraces, make them more
(load! "cli/lib/lib") ;; presentable, and write them to a file. Cleaner backtraces are better UX than
(load! "cli/lib/straight-hacks") ;; the giant wall of text the default debugger throws up.
(setq debugger #'doom-cli-debugger)
;; 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))
;; Create all our core directories to quell file errors. ;; Create all our core directories to quell file errors.
(mapc (doom-rpartial #'make-directory 'parents) (mapc (doom-rpartial #'make-directory 'parents)
@ -60,214 +112,8 @@ purpose.")
doom-etc-dir doom-etc-dir
doom-cache-dir)) doom-cache-dir))
;; Ensure straight and core packages are ready to go for CLI commands. ;; Load standard :help and :version handlers.
(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! "cli/help") (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) (provide 'core-cli)
;;; core-cli.el ends here ;;; core-cli.el ends here

27
core/core-lib.el
View file

@ -70,23 +70,6 @@ list is returned as-is."
(cl-check-type keyword keyword) (cl-check-type keyword keyword)
(substring (symbol-name keyword) 1)) (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) (defalias 'doom-partial #'apply-partially)
(defun doom-rpartial (fn &rest args) (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! () (defun file! ()
"Return the emacs lisp file this function is called from." "Return the emacs lisp file this function is called from."
(cond ((bound-and-true-p byte-compile-current-file)) (cond (load-in-progress load-file-name)
(load-file-name) ((bound-and-true-p byte-compile-current-file))
((stringp (car-safe current-load-list)) ((stringp (car-safe current-load-list))
(car current-load-list)) (car current-load-list))
(buffer-file-name) (buffer-file-name)
@ -558,6 +541,8 @@ This is a wrapper around `eval-after-load' that:
(cons 'doom-error doom-core-dir)) (cons 'doom-error doom-core-dir))
((file-in-directory-p source doom-private-dir) ((file-in-directory-p source doom-private-dir)
(cons 'doom-private-error 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))))) ((cons 'doom-module-error doom-emacs-dir)))))
(signal (car err) (signal (car err)
(list (file-relative-name (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" (error "Could not detect path to look for '%s' in"
filename))) filename)))
(file (if path (file (if path
`(expand-file-name ,filename ,path) `(expand-file-name ,filename ,path)
filename))) filename)))
`(condition-case-unless-debug e `(condition-case-unless-debug e
(let (file-name-handler-alist) (let (file-name-handler-alist)
(load ,file ,noerror 'nomessage)) (load ,file ,noerror 'nomessage))

4
modules/app/everywhere/cli.el
View file

@ -1,5 +1,5 @@
;;; app/everywhere/cli.el -*- lexical-binding: t; -*- ;;; app/everywhere/cli.el -*- lexical-binding: t; -*-
(defcli! everywhere () (defcli! () ()
"Spawn an emacsclient window for quick edits." "Spawn an emacsclient window for quick edits."
(throw 'exit (list "emacsclient" "--eval" "(emacs-everywhere)"))) (throw :exit "emacsclient --eval '(emacs-everywhere)'"))

6
modules/config/literate/autoload.el
View file

@ -27,7 +27,7 @@ byte-compiled from.")
;; Ensure output conforms to the formatting of all doom CLIs ;; Ensure output conforms to the formatting of all doom CLIs
(defun message (msg &rest args) (defun message (msg &rest args)
(when msg (when msg
(print! (info "%s") (apply #'format msg args))))) (print! (item "%s") (apply #'format msg args)))))
(print! (start "Compiling your literate config...")) (print! (start "Compiling your literate config..."))
(print-group! (print-group!
(let (;; Do as little unnecessary work as possible in these org files. (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 ;; Write an empty file to serve as our mtime cache
(with-temp-file cache) (with-temp-file cache)
(if doom-interactive-p t (if doom-interactive-p t
(message "Restarting..." ) (print! "Restarting...")
(throw 'exit "__DOOMRESTART=1 __NOTANGLE=1 $@")))))) (exit! "__DOOMRESTART=1 __NOTANGLE=1 $@"))))))
;;;###autoload ;;;###autoload
(defalias '+literate/reload #'doom/reload) (defalias '+literate/reload #'doom/reload)

2
modules/config/literate/cli.el
View file

@ -3,4 +3,4 @@
(load! "autoload") (load! "autoload")
;; Tangle the user's config.org before 'doom sync' runs ;; 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)

1
modules/lang/emacs-lisp/autoload.el
View file

@ -239,6 +239,7 @@ https://emacs.stackexchange.com/questions/10230/how-to-indent-keywords-aligned"
("Advice" "^\\s-*(\\(?:def\\(?:\\(?:ine-\\)?advice!?\\)\\) +\\([^ )\n]+\\)" 1) ("Advice" "^\\s-*(\\(?:def\\(?:\\(?:ine-\\)?advice!?\\)\\) +\\([^ )\n]+\\)" 1)
("Macros" "^\\s-*(\\(?:cl-\\)?def\\(?:ine-compile-macro\\|macro\\) +\\([^ )\n]+\\)" 1) ("Macros" "^\\s-*(\\(?:cl-\\)?def\\(?:ine-compile-macro\\|macro\\) +\\([^ )\n]+\\)" 1)
("Inline functions" "\\s-*(\\(?:cl-\\)?defsubst +\\([^ )\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) ("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) ("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)))) ("Types" "^\\s-*(\\(cl-def\\(?:struct\\|type\\)\\|def\\(?:class\\|face\\|group\\|ine-\\(?:condition\\|error\\|widget\\)\\|package\\|struct\\|t\\(?:\\(?:hem\\|yp\\)e\\)\\)\\)\\s-+'?\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)+\\)" 2))))