diff --git a/bin/doom b/bin/doom index a99ea0afa..b4a21695b 100755 --- a/bin/doom +++ b/bin/doom @@ -297,7 +297,7 @@ SEE ALSO: (let ((cli-file "cli.el")) (defcli-group! "Module commands" - (with-doom-context 'modules + (with-doom-context 'module (dolist (key (doom-module-list)) (when-let (path (doom-module-locate-path key cli-file)) (defcli-group! :prefix (if (cdr key) (format "+%s" (cdr key))) diff --git a/early-init.el b/early-init.el index d1a4c2a27..00fc823d2 100644 --- a/early-init.el +++ b/early-init.el @@ -133,8 +133,10 @@ ;; fit guess. It's better than Emacs' 80kb default. (setq gc-cons-threshold (* 16 1024 1024)) nil)) - ;; ...Otherwise, we're loading a Doom config, so continue as normal. - (doom-require (if noninteractive 'doom-cli 'doom-start)) + ;; In non-interactive sessions, leave to the consumer to call + ;; `doom-initialize' at the best time, otherwise we need to initialize + ;; ASAP for the Emacs session ahead. + (doom-initialize (not noninteractive)) ;; If we're here, the user wants to load another config/profile (that may or ;; may not be a Doom config). (load user-init-file 'noerror (not init-file-debug) nil 'must-suffix))) diff --git a/lisp/cli/doctor.el b/lisp/cli/doctor.el index 736e65a06..96200d02d 100644 --- a/lisp/cli/doctor.el +++ b/lisp/cli/doctor.el @@ -328,7 +328,7 @@ in." (packages-file (doom-module-expand-path (cons group name) doom-module-packages-file))) (when packages-file (cl-loop with doom-output-indent = 6 - for name in (with-doom-context 'packages + for name in (with-doom-context 'package (let* (doom-packages doom-disabled-packages) (load packages-file 'noerror 'nomessage) diff --git a/lisp/cli/packages.el b/lisp/cli/packages.el index 70b19ece4..6ec53f89c 100644 --- a/lisp/cli/packages.el +++ b/lisp/cli/packages.el @@ -277,8 +277,8 @@ remains lean." (straight--packages-to-rebuild (or (if force-p :all straight--packages-to-rebuild) (make-hash-table :test #'equal))) - (recipes (doom-package-recipe-list)) - (pinned (doom-package-pinned-list))) + (recipes (doom-package-recipe-alist)) + (pinned (doom-package-pinned-alist))) (add-hook 'native-comp-async-cu-done-functions #'doom-packages--native-compile-done-h) (straight--make-build-cache-available) (if-let (built @@ -374,8 +374,8 @@ remains lean." (doom-initialize-packages) (doom-packages--barf-if-incomplete) (let* ((repo-dir (straight--repos-dir)) - (pinned (doom-package-pinned-list)) - (recipes (doom-package-recipe-list)) + (pinned (doom-package-pinned-alist)) + (recipes (doom-package-recipe-alist)) (packages-to-rebuild (make-hash-table :test 'equal)) (repos-to-rebuild (make-hash-table :test 'equal)) (total (length recipes)) @@ -585,7 +585,6 @@ remains lean." (delq nil (mapcar #'doom-packages--purge-repo repos)))))) (defun doom-packages--purge-elpa () - (require 'doom-packages) (let ((dirs (doom-files-in package-user-dir :type t :depth 0))) (if (not dirs) (prog1 0 diff --git a/lisp/cli/profiles.el b/lisp/cli/profiles.el index 867c69673..d69047db4 100644 --- a/lisp/cli/profiles.el +++ b/lisp/cli/profiles.el @@ -69,15 +69,9 @@ (dolist (p removed) (print! (item "Removed %S") (car p))) (dolist (p changed) (print! (item "Changed %S") (car p))) (doom-file-write doom-cli-known-profiles-file (list new-profiles) :mode #o600) - (doom-profiles-save new-profiles load-file) + (doom-profiles-write-load-file new-profiles load-file) (print! (success "Regenerated profile loader: %s") (path load-file))))))))) - -;; -;;; Helpers - - - (provide 'doom-cli-profiles) ;;; profiles.el ends here diff --git a/lisp/doom-cli-lib.el b/lisp/doom-cli-lib.el deleted file mode 100644 index 43d180000..000000000 --- a/lisp/doom-cli-lib.el +++ /dev/null @@ -1,2352 +0,0 @@ -;;; lisp/doom-cli-lib.el --- API for Doom's CLI framework -*- lexical-binding: t; -*- - -(require 'doom-modules) -(require 'doom-packages) -(require 'doom-profiles) - -(defgroup doom-cli nil - "Doom's command-line interface framework." - :link '(url-link "https://doomemacs.org/cli") - :group 'doom) - -(defcustom doom-cli-load-path - (append (when-let ((doompath (getenv "DOOMPATH"))) - (cl-loop for dir in (split-string doompath path-separator) - collect (expand-file-name dir))) - (list (file-name-concat (dir!) "cli"))) - "A list of paths to search for autoloaded Doom CLIs. - -It is prefilled by the DOOMPATH envvar (a colon-separated list on Linux/macOS, -semicolon otherwise)." - :type '(list directory) - :group 'doom-cli) - - -;; -;;; CLI definition variables - -(defvar doom-cli-argument-types - '(&args - &cli - &context - &flags - &multiple - &optional - &rest - &required - &input - &whole) - "A list of auxiliary keywords allowed in `defcli!'s arglist. - -See `defcli!' for documentation on them.") - -(defvar doom-cli-option-types - '((&flag . &flags) - (&multi . &multiple)) - "An alist of auxiliary keywords permitted in option specs in `defcli!'. - -They serve as shorter, inline aliases for `doom-cli-argument-types'. - -See `defcli!' for documentation on them.") - -(defvar doom-cli-option-generators - '((&flags . doom-cli--make-option-flag) - (&multiple . doom-cli--make-option-multi) - (&required . doom-cli--make-option-generic) - (&optional . doom-cli--make-option-generic)) - "An alist of `doom-cli-option' factories for argument types. - -Types that - -See argument types in `doom-cli-argument-types', and `defcli!' for usage.") - -(defvar doom-cli-option-arg-types - `((dir :test file-directory-p - :read expand-file-name - :error "Not a valid path to an existing directory" - :zshcomp "_dirs") - (file :test file-exists-p - :read expand-file-name - :error "Not a valid path to an existing file" - :zshcomp "_files") - (stdout :test ,(lambda (str) (equal str "-")) - :read identity - :error "Not a dash to signal stdout" - :zshcomp "(-)") - (path :read expand-file-name :zshcomp "_files") - (form :read read) - (regexp :test ,(lambda (str) (always (string-match-p str "")))) - (int :test "^[0-9]+$" - :read string-to-number - :error "Not an integer") - (num :test "^[0-9]+\\(\\.[0-9]+\\)?$" - :read string-to-number - :error "Not a valid number or float") - (float :test "^[0-9]+\\(\\.[0-9]+\\)$" - :read string-to-number - :error "Not a float") - (bool :test "^y\\(?:es\\)?\\|no?\\|on\\|off\\|t\\(?:rue\\)?\\|false\\|[01]\\|$" - :read ,(lambda (x) - (pcase x - ((or "y" "yes" "t" "true" "1" "on") :yes) - ((or "n" "no" "nil" "false" "0" "off") :no))) - :error "Not a valid boolean, should be blank or one of: yes, no, y, n, true, false, on, off" - :zshcomp "(y n yes no true false on off 1 0)") - (date :test ,(lambda (str) - (let ((ts (parse-time-string str))) - (and (decoded-time-day ts) - (decoded-time-month ts) - (decoded-time-year ts)))) - :read parse-time-string - :error "Not a valid date (try YYYY-MM-DD or a date produced by `date')") - (time :test ,(lambda (str) - (let ((ts (parse-time-string str))) - (and (decoded-time-hour ts) - (decoded-time-minute ts) - (decoded-time-second ts)))) - :read parse-time-string - :error "Not a valid date (try YYYY-MM-DD or a date produced by `date')") - (duration :test ,(lambda (str) - (not (cl-loop for d in (split-string-and-unquote str " ") - unless (string-match-p "^[0-9]+[hmsdMY]$" d) - return t))) - :read ,(doom-rpartial #'split-string-and-unquote " ") - :error "Not a valid duration (e.g. 5h 20m 40s 2Y 1M)") - (size :test "^[0-9]+[kmgt]?b$" - :read ,(lambda (str) - (save-match-data - (and (string-match "^\\([0-9]+\\(?:\\.[0-9]+\\)\\)\\([kmgt]?b\\)$" str) - (* (string-to-number (match-string 1 str)) - (or (cdr (assoc (match-string 2 str) - '(("kb" . 1000) - ("mb" . 1000000) - ("gb" . 1000000000) - ("tb" . 1000000000000)))) - 1))))) - :error "Not a valid filesize (e.g. 5mb 10.4kb 2gb 1.4tb)")) - "A list of implicit option argument datatypes and their rules. - -Recognizies the following properies: - - :test FN - Predicate function to determine if a value is valid. - :read FN - A transformer that converts the string argument to a desired format. - :error STR - The message to display if a value fails :test.") - -;;; Post-script settings -(defvar doom-cli-exit-commands - '(;; (:editor . doom-cli--exit-editor) - ;; (:emacs . doom-cli--exit-emacs) - (:pager . doom-cli--exit-pager) - (:pager? . doom-cli--exit-pager-maybe) - (:restart . doom-cli--exit-restart)) - "An alist of commands that `doom-cli--exit' recognizes.") - -(defcustom doom-cli-pager (getenv "DOOMPAGER") - "The PAGER command to use. - -If nil, falls back to less." - :type 'string - :group 'doom-cli) - -(defcustom doom-cli-pager-ratio 1.0 - "If output exceeds TTY height times this ratio, the pager is invoked. - -Only applies if (exit! :pager) or (exit! :pager?) are called." - :type 'float - :group 'doom-cli) - -;;; Logger settings -(defvar doom-cli-log-file-format (expand-file-name "logs/cli.%s.%s.%s" doom-state-dir) - "Where to write any output/log file to. - -Must have two arguments, one for session id and the other for log type.") - -(defvar doom-cli-log-retain 12 - "Number of each log type to retain.") - -(defvar doom-cli-log-backtrace-depth 12 - "How many frames of the backtrace to display in stdout.") - -(defvar doom-cli-log-straight-error-lines 16 - "How many lines of straight.el errors to display in stdout.") - -(defvar doom-cli-log-benchmark-threshold 5 - "How much execution time (in seconds) before benchmark is shown. - -If set to nil, only display benchmark if a CLI explicitly requested with a -non-nil :benchmark property. -If set to `always', show the benchmark no matter what.") - -(defvar doom-cli-shell - (pcase (getenv "__DOOMSH") - ("ps1" 'pwsh) - (_ 'sh)) - "What shell environment Doom has been started with. - -Can be `pwsh' if invoked via bin/doom.ps1, or `sh' in unix environments.") - -;;; Internal variables -(defvar doom-cli--context nil) -(defvar doom-cli--exit-code 255) -(defvar doom-cli--group-plist nil) -(defvar doom-cli--table (make-hash-table :test 'equal)) - - -;; -;;; Custom hooks - -(defcustom doom-cli-create-context-functions () - "A hook executed once a new context has been generated. - -Called by `doom-cli-context-parse' and `doom-cli-context-restore', once a -`doom-cli-context' is fully populated and ready to be executed (but before it -has). - -Hooks are run with one argument: the newly created context." - :type 'hook - :group 'doom-cli) - -(defcustom doom-cli-before-run-functions () - "Hooks run before `run!' executes the command. - -Runs with a single argument: the active context (a `doom-cli-context' struct)." - :type 'hook - :group 'doom-cli) - -(defcustom doom-cli-after-run-functions () - "Hooks run after `run!' has executed the command. - -Runs with two arguments: the active context (a `doom-cli-context' struct) and -the return value of the executed CLI." - :type 'hook - :group 'doom-cli) - - -;; -;;; Errors - -(define-error 'doom-cli-definition-error "Invalid CLI definition" 'doom-cli-error) -(define-error 'doom-cli-autoload-error "Failed to autoload deferred command" 'doom-cli-error) -(define-error 'doom-cli-invalid-prefix-error "Prefix has no defined commands" 'doom-cli-error) -(define-error 'doom-cli-command-not-found-error "Could not find that command" 'doom-cli-error) -(define-error 'doom-cli-wrong-number-of-arguments-error "Wrong number of CLI arguments" 'doom-cli-error) -(define-error 'doom-cli-unrecognized-option-error "Not a recognized option" 'doom-cli-error) -(define-error 'doom-cli-invalid-option-error "Invalid option value" 'doom-cli-error) - - -;; -;;; `doom-cli' - -(cl-defstruct doom-cli - "An executable CLI command." - (command nil :read-only t) - type - docs - autoload - alias - options - arguments - plist - fn) - -(defun doom-cli-execute (cli bindings) - "Execute CLI with BINDINGS (an alist). - -BINDINGS is an alist of (SYMBOL . VALUE) to bind lexically during CLI's -execution. Can be generated from a `doom-cli-context' with -`doom-cli--bindings'." - (doom-log "execute: %s %s" (doom-cli-key cli) bindings) - (funcall (doom-cli-fn cli) cli bindings)) - -(defun doom-cli-key (cli) - "Return CLI's (type . command), used as a table key or unique identifier." - (let ((command (doom-cli-command cli))) - (if-let (type (doom-cli-type cli)) - (cons type command) - command))) - -(defun doom-cli-command-normalize (command &optional plist) - "Ensure that COMMAND is properly formatted. - -This means that all non-keywords are strings, any prefixes provided by PLIST are -prepended, and the keyword is in front." - (let* ((command (ensure-list command)) - (prefix (plist-get plist :prefix)) - (prefix (if prefix (doom-cli-command-normalize - prefix (append `(:prefix nil) plist)))) - (command (append prefix command)) - (type (cl-find-if #'keywordp (remq :root command) :from-end t)) - (command (seq-subseq - command (or (cl-position :root command :from-end t) - 0)))) - (when (or command prefix) - (cl-loop with map = (fn! (if (or (stringp %) (keywordp %)) % (prin1-to-string %))) - for c in (delq nil (cons type (seq-remove #'keywordp command))) - if (listp c) - collect (mapcar map c) - else collect (funcall map c))))) - -(defun doom-cli-command-string (command) - "Return a joined string representation of normalized COMMAND. - -COMMAND should either be a command list (e.g. '(doom foo bar)) or a `doom-cli' -struct." - (mapconcat (doom-partial #'format "%s") - (doom-cli--command command) - " ")) - -(defun doom-cli-get (command &optional noresolve? noload?) - "Return CLI at COMMAND. - -Will autoload COMMAND if it was deferred with `defcli-autoload!'. - -If NORESOLVE?, don't follow aliases." - (when-let* ((command (doom-cli--command command)) - (cli (gethash command doom-cli--table)) - (cli (if noload? cli (doom-cli-load cli)))) - (if noresolve? - cli - (let (path) - (while (setq path (ignore-errors (doom-cli-alias cli))) - (setq cli (doom-cli-get path t noload?))) - (unless cli - (signal 'doom-cli-command-not-found-error (or path command))) - cli)))) - -(defun doom-cli-path (cli &optional noload?) - "Return a list of `doom-cli's encountered while following CLI's aliases. - -If NOLOAD? is non-nil, don't autoload deferred CLIs (see `doom-cli-get')." - (when cli - (cons - cli (let (alias paths) - (while (setq alias (ignore-errors (doom-cli-alias cli))) - (and (setq cli (doom-cli-get alias t noload?)) - (push cli paths))) - (nreverse paths))))) - -(defun doom-cli-find (command &optional nopartials?) - "Find all CLIs assocated with COMMAND, including partials. - -COMMAND can be a command path (list of strings), a `doom-cli' struct, or a -`doom-cli-context' struct. - -Returned in the order they will execute. Includes pseudo CLIs." - (let* ((command (doom-cli--command command)) - (paths (nreverse (doom-cli--command-expand command t))) - results clis) - (push '(:after) results) - (dolist (path paths) - (push (cons :after path) results)) - (push command results) - (dolist (path (nreverse paths)) - (push (cons :before path) results)) - (push '(:before) results) - (dolist (result results (nreverse clis)) - (when-let ((cli (doom-cli-get result t)) - ((or (not nopartials?) - (doom-cli-type cli)))) - (cl-pushnew cli clis - :test #'equal - :key #'doom-cli-key))))) - -(defun doom-cli-prop (cli prop &optional null-value) - "Returns a PROPerty of CLI's plist, or NULL-VALUE if it doesn't exist." - (let ((plist (doom-cli-plist cli))) - (if (plist-member plist prop) - (plist-get plist prop) - null-value))) - -(cl-defun doom-cli-subcommands (command &optional (depth 9999) &key tree? all? predicate?) - "Return a list of subcommands, DEPTH levels deep, below COMMAND. - - If DEPTH is non-nil, list *all* subcommands, recursively. Otherwise it expects -an integer. - If TREE?, return commands in a tree structure. - If ALL?, include hidden commands (like aliases)." - (when (or (null depth) (> depth 0)) - (catch :predicate - (let* ((command (doom-cli--command command t)) - (prefixlen (length command)) - results) - (dolist (cli (hash-table-values doom-cli--table)) - (let ((clicmd (doom-cli-command cli))) - (when (and (not (doom-cli-type cli)) - (= (length clicmd) (1+ prefixlen)) - (equal command (seq-take clicmd prefixlen)) - (or all? (not (doom-cli-prop cli :hide)))) - (when predicate? - (throw :predicate t)) - (let* ((car (if tree? (car (last clicmd)) clicmd)) - (cdr (doom-cli-subcommands - clicmd (if depth (1- depth)) - :tree? tree? - :all? all?))) - (if tree? - (push (if cdr (cons car cdr) car) results) - (cl-callf nconc results (cons car cdr))))))) - (if tree? - (nreverse results) - results))))) - -(defun doom-cli-aliases (cli) - "Return all known `doom-cli's that are aliased to CLI. - -This cannot see autoloaded CLIs. Use `doom-cli-load' or `doom-cli-load-all' -to reach them." - (cl-loop with cli = (doom-cli-get cli) - with key = (doom-cli-key cli) - for rcli in (hash-table-values doom-cli--table) - if (equal key (doom-cli-key rcli)) - collect cli)) - -(defun doom-cli-short-docs (cli) - "Return the first line of CLI's documentation. - -Return nil if CLI (a `doom-cli') has no explicit documentation." - (ignore-errors (cdr (assoc "SUMMARY" (doom-cli-docs cli))))) - -(defun doom-cli--bindings (cli context &optional seen) - "Return a CLI with a value alist in a cons cell." - (let* ((optspec (doom-cli-options cli)) - (argspec (doom-cli-arguments cli)) - alist) - ;; Ensure all symbols are defined - (dolist (opt optspec) - (setf (alist-get (doom-cli-option-symbol opt) alist) - (doom-cli-option-default opt))) - (dolist (syms argspec) - (dolist (sym (cdr syms)) - (setf (alist-get sym alist) nil))) - ;; Populate options - (let ((options (doom-cli-context-options context))) - (dolist (opt optspec) - (when-let (option (cl-loop for flag in (doom-cli-option-switches opt) - if (cdr (assoc flag options)) - return (cons flag it))) - (unless (member (car option) seen) - (setf (alist-get (doom-cli-option-symbol opt) alist) - (cdr option)) - (push (car option) seen))))) - ;; Populate arguments - (let* ((arglist (doom-cli-context-arguments context)) - (rest (copy-sequence (map-elt arglist (doom-cli-command cli)))) - (args (copy-sequence (alist-get t arglist))) - (argc (length args)) - (required (alist-get '&required argspec)) - (optional (alist-get '&optional argspec)) - (spec (append required optional)) - (min (length required)) - (max (if (or (assq '&args argspec) - (assq '&rest argspec)) - most-positive-fixnum - (length spec)))) - (when (or (< argc min) - (> argc max)) - (signal 'doom-cli-wrong-number-of-arguments-error - (list (doom-cli-key cli) nil args min max))) - (dolist (sym spec) - (setf (alist-get sym alist) (if args (pop args)))) - (dolist (type `((&args . ,args) - (&cli . ,cli) - (&context . ,context) - (&input - . ,(if (doom-cli-context-pipe-p context :in t) - (with-current-buffer (doom-cli-context-stdin context) - (buffer-string)))) - (&rest . ,rest) - (&whole . ,(doom-cli-context-whole context)))) - (when-let (var (car (alist-get (car type) argspec))) - (setf (alist-get var alist) (cdr type))))) - alist)) - -(defun doom-cli--command (target &optional notype?) - "Fetch the normalized command from TARGET. - -If NOTYPE? is non-nil, omit any leading keywords from the command. - -TARGET can be a `doom-cli', `doom-cli-context', or a command list." - (cond ((doom-cli-p target) - (if notype? - (doom-cli-command target) - (doom-cli-key target))) - ((doom-cli-context-p target) - (doom-cli-context-command target)) - ((and target (not (listp target))) - (signal 'wrong-type-argument - (list '(doom-cli-p doom-cli-context-p listp) target))) - ((let ((target (doom-cli-command-normalize target))) - (if (and notype? (keywordp (car target))) - (cdr target) - target))))) - -(defun doom-cli--command-expand (commandspec &optional recursive?) - "Expand COMMANDSPEC into a list of commands. - -If RECURSIVE, includes breadcrumbs leading up to COMMANDSPEC." - (funcall (if recursive? - #'identity - (fn! (cl-loop with cmdlen = (length (car %)) - for command in % - while (= (length command) cmdlen) - collect command))) - (seq-reduce (lambda (init next) - (nconc (cl-loop with firstlen = (length (car init)) - for seg in (ensure-list next) - nconc - (cl-loop for command in init - while (= (length command) firstlen) - collect (append command (list seg)))) - init)) - (cdr commandspec) - `(,@(mapcar #'list (ensure-list (car commandspec))))))) - -(defun doom-cli--parse-docs (docs) - (when (and (stringp docs) - (not (equal docs "TODO"))) - (let ((re "^\\([A-Z0-9 _-]+\\):\n") sections) - (with-temp-buffer - (save-excursion - (insert "__DOOMDOCS__:\n") - (insert docs)) - (while (re-search-forward re nil t) - (push (cons (match-string 1) - (let ((buffer (current-buffer)) - (beg (match-end 0)) - (end (save-excursion - (if (re-search-forward re nil t) - (1- (match-beginning 0)) - (point-max))))) - (with-temp-buffer - (insert-buffer-substring buffer beg end) - (goto-char (point-min)) - (indent-rigidly (point-min) (point-max) (- (skip-chars-forward " "))) - (string-trim-right (buffer-string))))) - sections))) - (let ((lines (split-string (cdr (assoc "__DOOMDOCS__" sections)) "\n")) - (sections (assoc-delete-all "__DOOMDOCS__" sections))) - `(("SUMMARY" . ,(car lines)) - ("MAIN" . ,(string-trim (string-join (cdr lines) "\n"))) - ,@(nreverse sections)))))) - - -;; -;;; `doom-cli-option' - -(cl-defstruct doom-cli-option - "A switch specification dictating the characteristics of a recognized option." - (symbol nil :read-only t) - docs - multiple-p - flag-p - switches - arguments - default) - -(defun doom-cli-option-validate (option &rest values) - "Test if OPTION will accept VALUES, and conforms them if necessary. - -OPTION is a `doom-cli-option' struct. VALUES can be any arbitrary values. -Returns VALUES once mapped through their respective reader (as dictated by -`doom-cli-option-arg-types'). - -Throws `doom-cli-invalid-option-error' for illegal values." - (let ((args (doom-cli-option-arguments option)) - (values (copy-sequence values))) - (dotimes (i (length args) values) - (let ((value (nth i values)) - (types (ensure-list (nth i args))) - errors) - (catch 'done - (dolist (type types) - ;; REVIEW Use pcase-let + map.el when 27.x support is dropped - (cl-destructuring-bind (&key test read error &allow-other-keys) - (if (or (symbolp type) - (and (stringp type) - (string-match-p "^[A-Z0-9-_]+$" type))) - (cdr (assq (if (symbolp type) type (intern (downcase type))) - doom-cli-option-arg-types)) - (list 'str :test #'stringp)) - (condition-case-unless-debug e - (or (and (or (null test) - (if (stringp test) - (and (string-match-p test value) t) - (funcall test value))) - (or (null read) - (setf (nth i values) (funcall read value))) - (throw 'done t)) - (push error errors)) - ((invalid-regexp invalid-read-syntax) - (push (error-message-string e) errors))))) - (signal 'doom-cli-invalid-option-error - (list types option value errors))))))) - -(defun doom-cli--read-option-switches (optspec) - (delq - nil (cl-loop for spec in optspec - if (and (stringp spec) - (string-match-p "^-\\(?:-[a-zA-Z0-9]\\|[^-]$\\)" spec)) - collect spec))) - -(defun doom-cli--read-option-args (argspec) - (delq - nil (cl-loop for spec in argspec - if (or (and (stringp spec) - (not (string-match-p "^-\\(?:-[a-zA-Z0-9]\\|[^-]$\\)" spec))) - (keywordp spec) - (symbolp spec) - (listp spec)) - collect spec))) - -(defun doom-cli--make-option-generic (symbol spec &optional docs) - (make-doom-cli-option - :symbol symbol - :docs docs - :switches (doom-cli--read-option-switches spec) - :arguments (doom-cli--read-option-args spec))) - -(defun doom-cli--make-option-flag (symbol spec &optional docs) - (let ((switches (doom-cli--read-option-switches spec)) - (args (doom-cli--read-option-args spec))) - (when (and args - (not (or (memq :yes args) - (memq :no args)))) - (signal 'doom-cli-definition-error - (list "Argument type %s cannot accept arguments for: %s" - '&flag (mapconcat #'symbol-name spec ", ")))) - (make-doom-cli-option - :symbol symbol - :docs docs - :flag-p t - :switches switches - :default (car args)))) - -(defun doom-cli--make-option-multi (symbol spec &optional docs) - (make-doom-cli-option - :symbol symbol - :docs docs - :multiple-p t - :switches (doom-cli--read-option-switches spec) - :arguments (doom-cli--read-option-args spec))) - - -;; -;;; `doom-cli-context' - -(cl-defstruct doom-cli-context - "A CLI context, containing all state pertinent to the current session." - (init-time before-init-time) ; When this context was created - ;; A session-specific ID of the current context (defaults to number - (pid (if-let (pid (getenv "__DOOMPID")) - (string-to-number pid) - (emacs-pid))) - ;; Number of Emacs processes this context has been processed through - (step (if-let (step (getenv "__DOOMSTEP")) - (string-to-number step) - -1)) - ;; The geometry of the terminal window. - (geometry (save-match-data - (when-let* ((geom (getenv "__DOOMGEOM")) - ((string-match "^\\([0-9]+\\)x\\([0-9]+\\)$" geom))) - (cons (string-to-number (match-string 1 geom)) - (string-to-number (match-string 2 geom)))))) - ;; Whether the script is being piped into or out of - (pipes (cl-loop for (env . scope) in `((,(getenv "__DOOMGPIPE") . global) - (,(getenv "__DOOMPIPE") . local)) - if (stringp env) - for pipes = (string-to-list env) - nconc `(,@(if (memq ?0 pipes) `((:in . ,scope))) - ,@(if (memq ?1 pipes) `((:out . ,scope))))) - :skip t) - ;; If non-nil, suppress prompts and auto-accept their consequences. - suppress-prompts-p - (prefix "@") ; The basename of the script creating this context - meta-p ; Whether or not this is a help/meta request - error ; - (command nil :skip t) ; The full command that led to this context - (path nil :skip t) ; Breadcrumb list of resolved commands so far - (whole nil :skip t) ; Unfiltered and unprocessed list of arguments - (options nil :skip t) ; An alist of (flags . value) - (arguments nil :skip t) ; An alist of non-subcommand arguments, by command - (stdin (generate-new-buffer " *doom-cli stdin*") :type buffer) ; buffer containing anything piped into this session - (stdout (generate-new-buffer " *doom-cli stdout*") :type buffer) ; buffer containing user-visible output - (stderr (generate-new-buffer " *doom-cli stderr*") :type buffer) ; buffer containing all output, including debug output - ;; An alist of persistent and arbitrary elisp state - (state nil :type alist)) - -(defun doom-cli-context-execute (context) - "Execute a given CONTEXT. - -Use `doom-cli-context-parse' or `doom-cli-context-restore' to produce a valid, -executable context." - (let* ((command (doom-cli-context-command context)) - (cli (doom-cli-get command t)) - (prefix (doom-cli-context-prefix context))) - (doom-log "context-execute: %s" - (mapconcat #'doom-cli-command-string - (delq nil (list (car (doom-cli-context-path context)) command)) - " -> ")) - (cond ((null (or command (doom-cli-get (list prefix) t))) - (signal 'doom-cli-invalid-prefix-error (list prefix))) - - ((doom-cli-context-meta-p context) - (pcase (doom-cli-context-meta-p context) - ("--version" - (doom-cli-call `(:version ,@(cdr command)) context) - t) - ((or "-?" "--help") - (doom-cli-call `(:help ,@(cdr command)) context) - t) - (_ (error "In meta mode with no destination!")))) - - ((not (and cli (doom-cli-fn (doom-cli-get cli)))) - (signal 'doom-cli-command-not-found-error - (append command (alist-get t (doom-cli-context-arguments context))))) - - ((let ((seen '(t)) - runners) - (dolist (cli (doom-cli-find command (doom-cli-type cli))) - (push (cons (doom-cli-get cli) - (doom-cli--bindings cli context seen)) - runners)) - (pcase-dolist (`(,cli . ,bindings) (nreverse runners)) - (doom-cli-execute cli bindings)) - context))))) - -(defun doom-cli-context-restore (file context) - "Restore the last restarted context from FILE into CONTEXT." - (when (and (stringp file) - (file-exists-p file)) - (when-let (old-context (with-temp-buffer - (insert-file-contents file) - (read (current-buffer)))) - (unless (doom-cli-context-p old-context) - (error "An invalid context was restored from file: %s" file)) - (unless (equal (doom-cli-context-prefix context) - (doom-cli-context-prefix old-context)) - (error "Restored context belongs to another script: %s" - (doom-cli-context-prefix old-context))) - (pcase-dolist (`(,slot ,_ . ,plist) - (cdr (cl-struct-slot-info 'doom-cli-context))) - (unless (plist-get plist :skip) - (let* ((idx (cl-struct-slot-offset 'doom-cli-context slot)) - (old-value (aref old-context idx))) - (aset context idx - (pcase (plist-get plist :type) - (`alist - (dolist (entry old-value (aref context idx)) - (setf (alist-get (car entry) (aref context idx)) (cdr entry)))) - (`buffer - (with-current-buffer (aref context idx) - (insert old-value) - (current-buffer))) - (_ old-value)))))) - (run-hook-with-args 'doom-cli-create-context-functions context) - (delete-file file) - (doom-log "context-restore: %s" (doom-cli-context-pid context)))) - context) - -(defun doom-cli-context-parse (args context) - "Parse ARGS and update CONTEXT to reflect it." - (let* ((case-fold-search t) - (args (delq nil (copy-sequence args))) - (arguments) - rest? - arg) - (while args - (setq arg (pop args)) - (save-match-data - (cond - ((equal arg "--") - (doom-log "context-parse: found arg separator" arg) - (setq arguments (cdr args) - args nil)) - - ((and (stringp arg) - (string-match "^\\(-\\([^-]\\{2,\\}\\)\\)" arg)) - (let ((chars (split-string (match-string 2 arg) "" t))) - (dolist (ch (nreverse chars)) - (push (concat "-" ch) args)))) - - ((and (stringp arg) - (or (string-match "^\\(--\\w[a-z0-9-_]+\\)\\(?:=\\(.*\\)\\)?$" arg) - (string-match "^\\(-[^-]\\)$" arg))) - (doom-log "context-parse: found switch %S" arg) - (catch :skip - (let* ((fullflag (match-string 1 arg)) - (normflag (if (string-prefix-p "--no-" fullflag) - (concat "--" (substring fullflag 5)) - fullflag)) - (option (or (doom-cli-context-find-option context normflag) - (when (member fullflag '("-?" "--help" "--version")) - (doom-log "context-parse: found help switch %S" arg) - (setf (doom-cli-context-meta-p context) fullflag) - (throw :skip t)) - (when rest? - (push arg arguments) - (throw :skip t)) - (signal 'doom-cli-unrecognized-option-error - (list fullflag)))) - (explicit-arg (match-string 2 arg)) - (arity (length (doom-cli-option-arguments option))) - (key (if (doom-cli-option-multiple-p option) - (car (doom-cli-option-switches option)) - normflag))) - (doom-cli-context-put - context key - (let ((value (seq-take args arity))) - (when explicit-arg - (push explicit-arg value)) - (when (/= (length value) arity) - (signal 'doom-cli-wrong-number-of-arguments-error - (list (doom-cli--command context) - fullflag value arity arity))) - (setq args (seq-drop args arity) - value (apply #'doom-cli-option-validate option value)) - (cond ((doom-cli-option-flag-p option) - (if (string-prefix-p "--no-" fullflag) :no :yes)) - ((doom-cli-option-multiple-p option) - (append (doom-cli-context-get context key) - (if (doom-cli-option-arguments option) - (cl-loop for v in value - collect (cons fullflag v)) - (list fullflag)))) - ((= arity 1) (car value)) - ((> arity 1) value) - (fullflag))))))) - - ((when-let* - (((null arguments)) - ((not rest?)) - (command (append (doom-cli-context-command context) (list arg))) - (cli (doom-cli-get command t)) - (rcli (doom-cli-get command)) - (key (doom-cli-key rcli))) - (doom-log "context-parse: found command %s" command) - ;; Show warnings depending on CLI plists - (when (doom-cli-alias cli) - (dolist (pcli (doom-cli-path cli)) - (doom-log "context-parse: path += %s" (doom-cli-key pcli)) - (push (doom-cli-key pcli) (doom-cli-context-path context)))) - ;; Collect &rest for this command - (setf (doom-cli-context-command context) key - (map-elt (doom-cli-context-arguments context) - (doom-cli-command rcli)) - (copy-sequence args)) - ;; Initialize options associated with this command to a nil value; - ;; this simplifies existence validation later. - (dolist (cli (doom-cli-find key)) - (dolist (option (doom-cli-options cli)) - (dolist (switch (doom-cli-option-switches option)) - (unless (assoc switch (doom-cli-context-options context)) - (setf (map-elt (doom-cli-context-options context) switch) - nil))))) - ;; If this command uses &rest, stop processing commands from this - ;; point on and pass the rest (of the unprocessed arguments) to it. - (when (and (doom-cli-fn rcli) - (alist-get '&rest (doom-cli-arguments rcli))) - (setq rest? t)) - t)) - - ((push arg arguments) - (doom-log "context-parse: found arg %S" arg))))) - - (setf (alist-get t (doom-cli-context-arguments context)) - (append (alist-get t (doom-cli-context-arguments context)) - (nreverse arguments))) - (run-hook-with-args 'doom-cli-create-context-functions context) - context)) - -(defun doom-cli-context-get (context key &optional null-value) - "Fetch KEY from CONTEXT's options or state. - -Context objects are essentially persistent storage, and may contain arbitrary -state tied to switches (\"--foo\" or \"-x\") or arbitrary symbols (state). - -If KEY is a string, fetch KEY from context's OPTIONS (by switch). -If KEY is a symbol, fetch KEY from context's STATE. -Return NULL-VALUE if KEY does not exist." - (if-let (value - (if (stringp key) - (assoc key (doom-cli-context-options context)) - (assq key (doom-cli-context-state context)))) - (cdr value) - null-value)) - -(defun doom-cli-context-put (context key val) - "Set KEY in CONTEXT's options or state to VAL. - -Context objects contain persistent storage, and may contain arbitrary state tied -to switches (\"--foo\" or \"-x\") or arbitrary symbols (state). Use this to -register data into CONTEXT. - -If KEY is a string, set the value of a switch named KEY to VAL. -If KEY is a symbol, set the value of the context's STATE to VAL." - (setf (alist-get - key (if (stringp key) - (doom-cli-context-options context) - (doom-cli-context-state context)) - nil nil #'equal) - val)) - -(defun doom-cli-context-find-option (context switch) - "Return a `doom-cli-option' belonging to SWITCH in CONTEXT, if available. - -Returns nil if SWITCH isn't a valid option in CONTEXT or none of the associated -`doom-cli's have a `doom-cli-option' associated with SWITCH." - (when (assoc switch (doom-cli-context-options context)) - (cl-loop with command = (doom-cli-context-command context) - for cli in (doom-cli-find command) - if (seq-find (lambda (opt) - (let ((switches (doom-cli-option-switches opt))) - (or (member switch switches) - (and (doom-cli-option-flag-p opt) - (string-prefix-p "--no-" switch))))) - (doom-cli-options cli)) - return it))) - -(defun doom-cli-context-width (context) - "Return the width (in character units) of CONTEXT's original terminal." - (or (car (doom-cli-context-geometry context)) - 80)) - -(defun doom-cli-context-height (context) - "Return the height (in character units) of CONTEXT's original terminal." - (or (cdr (doom-cli-context-geometry context)) - 40)) - -(defun doom-cli-context-pipe-p (context type &optional global?) - "Return non-nil if TYPE is an active pipe in the local CONTEXT. - -TYPE can be one of `:in' (receiving input on stdin) or `:out' (output is piped -to another process), or any of `local-in', `local-out', `global-in', or -`global-out'. - -If GLOBAL? is non-nil, if TYPE is `:in' or `:out', the global context (the pipes -active in the super-session, rather than the local Emacs instance) will be -considered as well." - (let ((pipes (doom-cli-context-pipes context))) - (and (if global? - (assq type pipes) - (member (cons type 'local) pipes)) - t))) - -(defun doom-cli-context-sid (context &optional nodate?) - "Return a unique session identifier for CONTEXT." - (if nodate? - (doom-cli-context-pid context) - (format (format-time-string - "%y%m%d%H%M%S.%%s" (doom-cli-context-init-time context)) - (doom-cli-context-pid context)))) - - -;; -;;; Output management - -(defun doom-cli-debugger (type data &optional context) - "Print a more presentable backtrace to terminal and write it to file." - ;; HACK Works around a heuristic in eval.c for detecting errors in the - ;; debugger, which executes this handler again on subsequent calls. Taken - ;; from `ert--run-test-debugger'. - (cl-incf num-nonmacro-input-events) - (let* ((inhibit-read-only nil) - (inhibit-message nil) - (inhibit-redisplay nil) - (inhibit-trace t) - (executing-kbd-macro nil) - (load-read-function #'read) - (backtrace (doom-backtrace)) - (context (or context (make-doom-cli-context))) - (straight-error - (and (bound-and-true-p straight-process-buffer) - (or (member straight-process-buffer data) - (string-match-p (regexp-quote straight-process-buffer) - (error-message-string data))) - (with-current-buffer (straight--process-buffer) - (split-string (buffer-string) "\n" t)))) - (error-file (doom-cli--output-file 'error context))) - (cond - (straight-error - (print! (error "The package manager threw an error")) - (print! (error "Last %d lines of straight's error log:") - doom-cli-log-straight-error-lines) - (print-group! - (print! - "%s" (string-join - (seq-subseq straight-error - (max 0 (- (length straight-error) - doom-cli-log-straight-error-lines)) - (length straight-error)) - "\n"))) - (print! (warn "Wrote extended straight log to %s") - (path (let ((coding-system-for-write 'utf-8-auto)) - (with-file-modes #o600 - (with-temp-file error-file - (insert-buffer-substring (straight--process-buffer)))) - error-file)))) - ((eq type 'error) - (let* ((generic? (eq (car data) 'error)) - (doom-cli-log-backtrace-depth doom-cli-log-backtrace-depth) - (print-escape-newlines t)) - (if (doom-cli-context-p context) - (print! (error "There was an unexpected runtime error")) - (print! (bold (error "There was a fatal initialization error")))) - (print-group! - (print! "%s %s" (bold "Message:") - (if generic? - (error-message-string data) - (get (car data) 'error-message))) - (unless generic? - (print! "%s %s" (bold "Details:") - (let* ((print-level 4) - (print-circle t) - (print-escape-newlines t)) - (prin1-to-string (cdr data))))) - (when backtrace - (print! (bold "Backtrace:")) - (print-group! - (dolist (frame (seq-take backtrace doom-cli-log-backtrace-depth)) - (print! "%s" (truncate (prin1-to-string - (cons (backtrace-frame-fun frame) - (backtrace-frame-args frame))) - (- (doom-cli-context-width context) - doom-print-indent - 1) - "...")))) - (when-let (backtrace-file (doom-backtrace-write-to-file backtrace error-file)) - (print! (warn "Wrote extended backtrace to %s") - (path backtrace-file)))))))) - (exit! 255))) - -(defmacro doom-cli-redirect-output (context &rest body) - "Redirect output from BODY to the appropriate log buffers in CONTEXT." - (declare (indent 1)) - (let ((contextsym (make-symbol "doomctxt"))) - `(let* ((,contextsym ,context) - ;; Emit more user-friendly backtraces - (debugger (doom-rpartial #'doom-cli-debugger ,contextsym)) - (debug-on-error t)) - (with-output-to! `((>= notice ,(doom-cli-context-stdout ,contextsym)) - (t . ,(doom-cli-context-stderr ,contextsym))) - ,@body)))) - -(defun doom-cli--output-file (type context) - "Return a log file path for TYPE and CONTEXT. - -See `doom-cli-log-file-format' for details." - (format doom-cli-log-file-format - (doom-cli-context-prefix context) - (doom-cli-context-sid context) - type)) - -(defun doom-cli--output-write-logs-h (context) - "Write all log buffers to their appropriate files." - (when (/= doom-cli--exit-code 254) - ;; Delete the last `doom-cli-log-retain' logs - (mapc #'delete-file - (let ((prefix (doom-cli-context-prefix context))) - (append (butlast (doom-glob (format doom-cli-log-file-format prefix "*" "log")) - doom-cli-log-retain) - (butlast (doom-glob (format doom-cli-log-file-format prefix "*" "error")) - doom-cli-log-retain)))) - ;; Then write the log file, if necessary - (let* ((buffer (doom-cli-context-stderr context)) - (file (doom-cli--output-file "log" context))) - (when (> (buffer-size buffer) 0) - (with-file-modes #o700 - (make-directory (file-name-directory file) t)) - (with-file-modes #o600 - (with-temp-file file - (insert-buffer-substring buffer) - (ansi-color-filter-region (point-min) (point-max)))))))) - -(defun doom-cli--output-benchmark-h (context) - "Write this session's benchmark to stdout or stderr, depending. - -Will also output it to stdout if requested (CLI sets :benchmark to t) or the -command takes >5s to run. If :benchmark is explicitly set to nil (or -`doom-cli-log-benchmark-threshold' is nil), under no condition should a -benchmark be shown." - (doom-cli-redirect-output context - (doom-log "%s (GCs: %d, elapsed: %.6fs)" - (if (= doom-cli--exit-code 254) "Restarted" "Finished") - gcs-done gc-elapsed) - (when-let* ((init-time (doom-cli-context-init-time context)) - (cli (doom-cli-get context)) - (duration (float-time (time-subtract (current-time) init-time))) - (hours (/ (truncate duration) 60 60)) - (minutes (- (/ (truncate duration) 60) (* hours 60))) - (seconds (- duration (* hours 60 60) (* minutes 60)))) - (when (and (/= doom-cli--exit-code 254) - (or (eq (doom-cli-prop cli :benchmark) t) - (eq doom-cli-log-benchmark-threshold 'always) - (and (eq (doom-cli-prop cli :benchmark :null) :null) - (not (doom-cli-context-pipe-p context 'out t)) - (> duration (or doom-cli-log-benchmark-threshold - most-positive-fixnum))))) - (print! (success "Finished in %s") - (join (list (unless (zerop hours) (format "%dh" hours)) - (unless (zerop minutes) (format "%dm" minutes)) - (format (if (> duration 60) "%ds" "%.5fs") - seconds)))))))) - - -;; -;;; Session management - -(defun doom-cli-call (args context &optional error) - "Process ARGS (list of string shell arguments) with CONTEXT as the basis. - -If ERROR is provided, store the error in CONTEXT, in case a later CLI wants to -read/use it (e.g. like a :help CLI)." - (let ((oldcommand (doom-cli-context-command context))) - (if oldcommand - (doom-log "call: %s -> %s" oldcommand args) - (doom-log "call: %s" oldcommand args)) - (when error - (setf (doom-cli-context-error context) error)) - (setf (doom-cli-context-command context) nil - (doom-cli-context-arguments context) nil - (doom-cli-context-meta-p context) nil) - (doom-cli-context-execute - (doom-cli-context-parse args (or context doom-cli--context))))) - -(defun doom-cli--restart (args context) - "Restart the current CLI session. - -If CONTEXT is non-nil, this is written to file and restored in the next Doom -session. - -This is done by writing a temporary shell script, which is executed after this -session ends (see the shebang lines of this file). It's done this way because -Emacs' batch library lacks an implementation of the exec system call." - (cl-check-type context doom-cli-context) - (when (= (doom-cli-context-step context) -1) - (error "__DOOMSTEP envvar missing; extended `exit!' functionality will not work")) - (let* ((pid (doom-cli-context-pid context)) - (step (doom-cli-context-step context)) - (shext (if (eq doom-cli-shell 'pwsh) "ps1" "sh")) - (context-file (format (doom-path temporary-file-directory "doom.%s.%s.context") pid step)) - (script-file (format (doom-path temporary-file-directory "doom.%s.%s.%s") pid step shext)) - (command (if (listp args) (combine-and-quote-strings (remq nil args)) args)) - (persistent-files - (combine-and-quote-strings (delq nil (list script-file context-file)))) - (persisted-env - (cl-remove-if-not - #'cdr (append - `(("DOOMPROFILE" . ,(ignore-errors (doom-profile->id doom-profile))) - ("EMACSDIR" . ,doom-emacs-dir) - ("DOOMDIR" . ,doom-user-dir) - ("DEBUG" . ,(if init-file-debug (number-to-string doom-log-level))) - ("__DOOMPID" . ,(number-to-string (doom-cli-context-pid context))) - ("__DOOMSTEP" . ,(number-to-string (doom-cli-context-step context))) - ("__DOOMCONTEXT" . ,context-file)) - (save-match-data - (cl-loop with initial-env = (get 'process-environment 'initial-value) - for env in (seq-difference process-environment initial-env) - if (string-match "^\\([a-zA-Z0-9_][^=]+\\)=\\(.+\\)$" env) - collect (cons (match-string 1 env) (match-string 2 env)))))))) - (cl-incf (doom-cli-context-step context)) - (with-file-modes #o600 - (doom-log "restart: writing context to %s" context-file) - (doom-file-write - context-file (let ((newcontext (copy-doom-cli-context context)) - (print-level nil) - (print-length nil) - (print-circle nil) - (print-escape-newlines t)) - ;; REVIEW: Use `print-unreadable-function' when 28 support - ;; is dropped. - (letf! (defmacro convert-buffer (fn) - `(setf (,fn newcontext) (with-current-buffer (,fn context) - (buffer-string)))) - (convert-buffer doom-cli-context-stdin) - (convert-buffer doom-cli-context-stdout) - (convert-buffer doom-cli-context-stderr)) - newcontext)) - (doom-log "restart: writing post-script to %s" script-file) - (doom-file-write - script-file - (pcase-exhaustive doom-cli-shell - (`sh `(,(if (featurep :system 'android) - "#!/bin/sh\n" - "#!/usr/bin/env sh\n") - "trap _doomcleanup EXIT\n" - "_doomcleanup() {\n rm -f " ,persistent-files "\n}\n" - "_doomrun() {\n " ,command "\n}\n" - ,(cl-loop for (var . val) in persisted-env - if (<= (length val) 2048) ; Prevent "Argument list too long" errors - concat (format "%s=%s \\\n" var (shell-quote-argument val)) - else do (doom-log 1 "restart: wiscarding envvar %S for being too long (%d)" var (length val))) - ,(format "PATH=\"%s%s$PATH\" \\\n" - (doom-path doom-emacs-dir "bin") - path-separator) - "_doomrun \"$@\"\n")) - (`pwsh `("try {\n" - ,(cl-loop for (var . val) in persisted-env - concat (format " $__%s = $env:%s; $env:%s = %S\n " - var var var val)) - ,command - "\n} finally {\n" - ,(cl-loop for file in persistent-files - concat (format " Remove-Item -Path %S\n " file)) - ,(cl-loop for (var . val) in envvars - concat (format " $env:%s = $__%s\n " var var)) - "\n}"))))) - (doom-log "_doomrun: %s %s" - (cl-loop for (var . val) in persisted-env - concat (format "%s=%s \\\n" var (shell-quote-argument val))) - command) - (doom-log "_doomcleanup: %s" persistent-files) - ;; Error code 254 is special: it indicates to the caller that the - ;; post-script should be executed after this session ends. It's up to - ;; `doom-cli-run's caller to enforce this (see bin/doom's shebang for a - ;; comprehensive example). - (doom-cli--exit 254 context))) - -(defun doom-cli--exit (args context) - "Accepts one of the following: - - (CONTEXT [ARGS...]) - TODO - (STRING [ARGS...]) - TODO - (:restart [ARGS...]) - TODO - (:pager [FILE...]) - TODO - (:pager? [FILE...]) - TODO - (INT) - TODO" - (let ((command (or (car-safe args) args)) - (args (if (car-safe args) (cdr-safe args)))) - (pcase command - ;; If an integer, treat it as an exit code. - ((pred (integerp)) - (setq doom-cli--exit-code command) - (kill-emacs command)) - - ;; Otherwise, run a command verbatim. - ((pred (stringp)) - (doom-cli--restart (format "%s %s" command (combine-and-quote-strings args)) - context)) - - ;; Same with buffers. - ((pred (bufferp)) - (doom-cli--restart (with-current-buffer command (buffer-string)) - context)) - - ;; If a context is given, restart the current session with the new context. - ((pred (doom-cli-context-p)) - (doom-cli--exit-restart args command)) - - ;; Run a custom action, defined in `doom-cli-exit-commands'. - ((pred (keywordp)) - (if-let (fn (alist-get command doom-cli-exit-commands)) - (funcall fn args context) - (error "Invalid exit command: %s" command))) - - ;; Any other value is invalid. - (_ (error "Invalid exit code or command: %s" command))))) - -(defun doom-cli--exit-restart (args context) - "Restart the session, verbatim (persisting CONTEXT). - -ARGS are addiitonal arguments to pass to the sub-process (in addition to the -ones passed to this one). It may contain :omit -- all arguments after this will -be removed from the argument list. They may specify number of arguments in the -format: - - --foo=4 omits --foo plus four following arguments - --foo=1 omits --foo plus one following argument - --foo= equivalent to --foo=1 - --foo=* omits --foo plus all following arguments - -Arguments don't have to be switches either." - (let ((pred (fn! (not (keywordp %)))) - (args (append (doom-cli-context-whole context) - (flatten-list args)))) - (let ((argv (seq-take-while pred args)) - (omit (mapcar (fn! (seq-let (arg n) (split-string % "=") - (cons - arg (cond ((not (stringp n)) 0) - ((string-empty-p n) 1) - ((equal n "*") -1) - ((string-to-number n)))))) - (seq-take-while pred (cdr (memq :omit args))))) - newargs) - (when omit - (while argv - (let ((arg (pop argv))) - (if-let (n (cdr (assoc arg omit))) - (if (= n -1) - (setq argv nil) - (dotimes (i n) (pop argv))) - (push arg newargs))))) - (doom-cli--exit (cons "$1" (or (nreverse newargs) argv)) - context)))) - -(defun doom-cli--exit-pager (args context) - "Invoke pager on output unconditionally. - -ARGS are options passed to less. If DOOMPAGER is set, ARGS are ignored." - (let ((pager (or doom-cli-pager (getenv "DOOMPAGER")))) - (cond ((eq doom-cli-shell 'pwsh) - ;; Pager isn't supported in powershell - (doom-cli--exit 0 context)) - - ((null (or pager (executable-find "less"))) - (user-error "No pager set or available") - (doom-cli--exit 1 context)) - - ((or (doom-cli-context-pipe-p context :out t) - (equal pager "")) - (doom-cli--exit 0 context)) - - ((let ((tmpfile (doom-cli--output-file 'output context)) - (coding-system-for-write 'utf-8)) - (with-file-modes #o700 - (make-directory (file-name-directory tmpfile) t)) - (with-file-modes #o600 - (with-temp-file tmpfile - (insert-buffer-substring (doom-cli-context-stdout context)))) - (doom-cli--restart - (format "%s <%s; rm -f%s %s" - (or pager - (format "less %s" - (combine-and-quote-strings - (append (if doom-print-backend '("-r")) ; process ANSI codes - (or (delq nil args) '("+g")))))) - (shell-quote-argument tmpfile) - (if init-file-debug "v" "") - (shell-quote-argument tmpfile)) - context)))))) - -(defun doom-cli--exit-pager-maybe (args context) - "Invoke pager if stdout is longer than TTY height * `doom-cli-pager-ratio'. - -ARGS are options passed to less. If DOOMPAGER is set, ARGS are ignored." - (doom-cli--exit - (if (eq doom-cli-shell 'pwsh) - 0 - (let ((threshold (ceiling (* (doom-cli-context-height context) - doom-cli-pager-ratio)))) - (if (>= (let ((stdout (doom-cli-context-stdout context))) - (if (fboundp 'buffer-line-statistics) - (car (buffer-line-statistics stdout)) - (with-current-buffer stdout - (count-lines (point-min) (point-max))))) - threshold) - (cons :pager args) - 0))) - context)) - -;; (defun doom-cli--exit-editor (args context)) ; TODO Launch $EDITOR - -;; (defun doom-cli--exit-emacs (args context)) ; TODO Launch Emacs subsession - - - -;; -;;; Migration paths - -;; (defvar doom-cli-context-restore-functions -;; '(doom-cli-context--restore-legacy-fn) -;; "A list of functions intended to unserialize `doom-cli-context'. - -;; They all take one argument, the raw data saved to $__DOOMCONTEXT. Each function -;; must return the version string corresponding to the version of Doom they have -;; transformed it for.") - -;; (defun doom-cli-context-restore (file context) -;; "Restore the last restarted context from FILE into CONTEXT." -;; (when (and (stringp file) -;; (file-exists-p file)) -;; (when-let* ((data (with-temp-buffer -;; (insert-file-contents file) -;; (read (current-buffer)))) -;; (version (if (stringp (car data)) (car data) "0")) -;; (old-context (if (string (car data)) (cdr data) data)) -;; (new-context (make-doom-cli-context)) -;; (struct-info (cl-loop for (slot _initval . plist) in (cdr (cl-struct-slot-info 'doom-cli-context)) -;; collect (cons (cl-struct-slot-offset 'doom-cli-context slot) -;; (cons slot plist))))) - -;; ;; (let ((version (if (stringp (car data)) (car data) "0")) -;; ;; (data (if (string (car data)) (cdr data) data)) -;; ;; (newcontext (make-doom-cli-context))) -;; ;; (dolist (fn doom-cli-context-restore-functions) -;; ;; (setq newcontext (funcall fn newcontext data version)))) - -;; (unless (doom-cli-context-p old-context) -;; (error "An invalid context was restored from file: %s" file)) -;; (unless (equal (doom-cli-context-prefix context) -;; (doom-cli-context-prefix old-context)) -;; (error "Restored context belongs to another script: %s" -;; (doom-cli-context-prefix old-context))) -;; (pcase-dolist (`(,slot ,_ . ,plist) -;; (cdr (cl-struct-slot-info 'doom-cli-context))) -;; (unless (plist-get plist :skip) -;; (let* ((idx (cl-struct-slot-offset 'doom-cli-context slot)) -;; (old-value (aref old-context idx))) -;; (aset context idx -;; (pcase (plist-get plist :type) -;; (`alist -;; (dolist (entry old-value (aref context idx)) -;; (setf (alist-get (car entry) (aref context idx)) (cdr entry)))) -;; (`buffer -;; (with-current-buffer (aref context idx) -;; (insert old-value) -;; (current-buffer))) -;; (_ old-value)))))) -;; (run-hook-with-args 'doom-cli-create-context-functions context) -;; (delete-file file) -;; (doom-log "Restored context: %s" (doom-cli-context-pid context)) -;; context))) - -;; (defun doom-cli-context--restore-legacy-fn (data old-version) -;; "Update `doom-cli-context' from <3.0.0 to 3.0.0." -;; (when (or (equal old-version "3.0.0-dev") -;; (string-match-p "^2\\.0\\." old-version)) - -;; "3.0.0")) - -;; (defun doom-cli-context--restore-3.1.0-fn (data old-version)) - - -;; -;;; Misc - -(defun doom-cli-load (cli) - "If CLI is autoloaded, load it, otherwise return it unchanged." - (or (when-let* ((path (doom-cli-autoload cli)) - (path (locate-file-internal path doom-cli-load-path load-suffixes))) - (doom-log "load: autoload %s" path) - (let ((doom-cli--group-plist (doom-cli-plist cli))) - (doom-load path)) - (let* ((key (doom-cli-key cli)) - (cli (gethash key doom-cli--table))) - (when (doom-cli-autoload cli) - (signal 'doom-cli-autoload-error (list (doom-cli-command cli) path))) - cli)) - cli)) - -(defun doom-cli-load-all () - "Immediately load all autoloaded CLIs." - (dolist (key (hash-table-keys doom-cli--table)) - (doom-cli-load (gethash key doom-cli--table)))) - - -;; -;;; DSL - -(defmacro defcli! (commandspec arglist &rest body) - "Defines a CLI command. - -COMMANDSPEC is the specification for the command that will trigger this CLI. It -can either be a symbol or list of symbols (or nested symbols). Nested lists are -treated as a list of aliases for the command. For example: - - (defcli! doom () ...) ; invoked on 'doom' - (defcli! (doom foo) () ...) ; invoked on 'doom foo' - (defcli! (doom (foo bar)) () ...) ; invoked on 'doom foo' or 'doom bar' - -COMMANDSPEC may be prefixed with any of these special keywords: - - :root ... - This command will ignore any :prefix set by a parent `defcli-group!'. - :before ... - This command will run before the specified command(s). - :after ... - This command will run after the specified command(s). - :version - A special handler, executed when 'X --version' is called. Define your own, - if you don't want it spewing Doom's version information. - :help COMMAND... - A special handler, executed when help documentation is requested for a - command. E.g. 'doom help foo' or 'doom foo --help' will call (:help foo). - You can define your own global :help handler, or one for a specific command. - :dump COMMAND... - A special handler, executed when the __DOOMDUMP environment variable is set. - You can define one for a specific COMMAND, or omit it to redefine the - catch-all :dump handler. - - The default implementation (living in lisp/doom-cli.el) will either: - - a) Dump to stdout a list of `doom-cli' structs for the commands and pseudo - commands that would've been executed had __DOOMDUMP not been set. - b) Or, given only \"-\" as an argument, dump all of `doom-cli--table' to - stdout. This table contains all known `doom-cli's (after loading - autoloaded ones). - -To interpolate values into COMMANDSPEC (e.g. to dynamically generate commands), -use the comma operator: - - (let ((somevar 'bfg)) - (defcli! (doom ,somevar) ...)) - -DOCSTRING is a string description; its first line should be a short summary -(under 60 characters) of what the command does. It will be used in the cramped -command listings served by help commands. The rest of DOCSTRING lines should be -no longer than 80 columns, and should go into greater detail. This documentation -may use `quoting' to appropriately highlight ARGUMENTS, --options, or $ENVVARS. - -DOCSTRING may also contain sections denoted by a capitalized header ending with -a colon and newline, and its contents indented by 2 spaces. These will be -appended to the end of the help documentation for that command. These three -sections are special: - - ARGUMENTS: - Use this to specify longer-form documentation for arguments. They are - prepended to the documentation for commands. If pseudo CLIs specify their - own ARGUMENTS sections, they are joined with that of the root command's CLI - as well. E.g. ':before doom sync's ARGUMENTS will be prepended to 'doom - sync's. - OPTIONS: - Use this to specify longer-form documentation for options. They are appended - to the auto-generated section of the same name. Only the option needs to be - specified for its lookup behavior to work. See bin/doom's `doom' command as - an example. - EXAMPLES: - To list example uses of the containing script. These are appended to - SYNOPSIS in generated manpages, but treated as a normal section otherwise - (i.e. appended to 'doom help's output). - -DOCSTRING may use any of these format specifications: - - %p The running script's prefix. E.g. for 'doom ci deploy-hooks' the - prefix is 'doom'. - %c The parent command minus the prefix. E.g. for 'doom ci deploy-hooks', - the command is 'ci deploy-hooks'. - -ARGLIST is a specification for options and arguments that is accepted by this -command. Arguments are represented by either a symbol or a cons cell where -(SYMBOL . DOCUMENTATION), and option specifications are lists in the following -formats: - - ([TYPE] VAR (FLAGSPEC... [ARGSPEC...]) [DESCRIPTION]) - - TYPE - Optional. One of &flag or &multi (which correspond to &flags and &multiple, - respectively, and are used for specifying a type inline, if desired). - VAR - Is the symbol to bind that option's value to. - FLAGSPEC - A list of switches or sub-lists thereof. Each switch is a string, e.g. - \"--foo\" \"-b\" \"--baz\". - - Nested lists will be treated as logical groups of switches in documentation. - E.g. for - - With (\"--foo\" \"--bar\" [ARGSPEC...]) you get: - - --foo, --bar - [Documentation] - - With ((\"--foo\") (\"--bar\") [ARGSPEC...]) you get: - - --foo - --bar - [Documentation] - - Use this to logically group options that have many, but semantically - distinct switches. - ARGSPEC - A list of arguments or sub-lists thereof. Each argument is either a string - or symbol. - - If a string, they are used verbatim as the argument's documentation. Use - this to document more complex specifications, like \"[user@]host[:port]\". - Use reference `quotes' to highlight arguments appropriately. No input - validation is performed on these arguments. - - If a symbol, this is equivalent to (upcase (format \"`%s'\" SYMBOL)), but - its arguments will also be implicitly validated against - `doom-cli-option-arg-types'. - - A nested list indicates that an argument accepts multiple types, and are - implicitly joined into \"`ARG1'|`ARG2'|...\". Input validation is performed - on symbols only. - - WARNING: If this option is a &flag, the option must not accept arguments. - Instead, use ARGSPEC to specify a single, default value (one of `:yes' or - `:no'). - DESCRIPTION - A one-line description of the option. Use reference `quotes' to - appropriately highlight arguments, options, and envvars. A syntax exists for - adding long-form option documentation from the CLI's docstring. See - DOCSTRING above. - -ARGLIST may be segmented with the following auxiliary keywords: - - &args ARG - The rest of the literal arguments are stored in ARG. - &cli ARG - The called `doom-cli' struct is bound to ARG. - &context ARG - The active `doom-cli-context' struct is bound to ARG. - &flags OPTION... - An option '--foo' declared after &flags will implicitly include a - '--no-foo', and will appear as \"--[no-]foo\" in 'doom help' docs. - &multiple OPTION... - Options specified after &multiple may be passed to the command multiple - times. Its symbol will be bound to a list of cons cells containing (FLAG . - VALUE). - &optional ARG... - Indicates that the (literal) arguments after it are optional. - &input ARG - ARG will be bound to the input piped in from stdin, as a string, or nil if - unavailable. If you want access to the original buffer, use - (doom-cli-context-stdin context) instead. - &rest ARG - All switches and arguments, unprocessed, after this command. If given, any - unrecognized switches will not throw an error. This will also prevent - subcommands beneath this command from being recognized. Use with care! - - Any non-option arguments before &optional, &rest, or &args are required. - -BODY is a list of arbitrary elisp forms that will be executed when this command -is called. BODY may begin with a plist to set metadata about it. The recognized -properties: - - :alias (CMD...) - Designates this command is an alias to CMD, which is a command specification - identical to COMMANDSPEC. - :benchmark BOOL - If non-nil, display a benchmark after the command finishes. - :disable BOOL - If non-nil, the command will not be defined. - :docs STRING - An alternative to DOCSTRING for defining documentation for this command. - :group (STR...) - A breadcrumb of group names to file this command under. They will be - organized by category in the CLI documentation (available through SCRIPT - {--help,-?,help}). - :hide BOOL - If non-nil, don't display this command in the help menu or in {ba,z}sh - completion (though it will still be callable). - :partial BOOL - If non-nil, this command is treated as partial, an intermediary command - intended as a stepping stone toward a non-partial command. E.g. were you to - define (doom foo bar), two \"partial\" commands are implicitly created: - \"doom\" and \"doom foo\". When called directly, partials will list its - subcommands and complain that a subcommand is rqeuired, rather than display - an 'unknown command' error. - :prefix (STR...) - A command path to prepend to the command name. This is more useful as part - of `defcli-group!'s inheritance. - -The BODY of commands with a non-nil :alias, :disable, or :partial will be -ignored. - -\(fn COMMANDSPEC ARGLIST [DOCSTRING] &rest BODY...)" - (declare (indent 2) (doc-string 3)) - (let ((docstring (if (stringp (car body)) (pop body))) - (plist (cl-loop for (key val) on body by #'cddr - while (keywordp key) - collect (pop body) - collect (pop body))) - options arguments bindings) - (let ((type '&required)) - (dolist (arg arglist) - (cond ((listp arg) - (let* ((inline-type (cdr (assq (car arg) doom-cli-option-types))) - (type (or inline-type type)) - (args (if inline-type (cdr arg) arg))) - (push (apply (or (alist-get type doom-cli-option-generators) - (signal 'doom-cli-definition-error - (cons "Invalid option type" type))) - args) - options) - (push (car args) bindings))) - ((memq arg doom-cli-argument-types) - (setq type arg)) - ((string-prefix-p "&" (symbol-name arg)) - (signal 'doom-cli-definition-error (cons "Invalid argument specifier" arg))) - ((push arg bindings) - (push arg (alist-get type arguments)))))) - (dolist (arg arguments) - (setcdr arg (nreverse (cdr arg)))) - `(let (;; Define function early to prevent overcapturing - (fn ,(let ((clisym (make-symbol "cli")) - (alistsym (make-symbol "alist"))) - `(lambda (,clisym ,alistsym) - (let ,(cl-loop for arg in (nreverse bindings) - unless (string-prefix-p "_" (symbol-name arg)) - collect `(,arg (cdr (assq ',arg ,alistsym)))) - ,@body))))) - ;; `cl-destructuring-bind's will validate keywords, so I don't have to - (cl-destructuring-bind - (&whole plist &key - alias autoload _benchmark docs disable hide _group partial - _prefix) - (append (list ,@plist) doom-cli--group-plist) - (unless disable - (let* ((command (doom-cli-command-normalize (backquote ,commandspec) plist)) - (type (if (keywordp (car command)) (pop command))) - (commands (doom-cli--command-expand command t)) - (target (pop commands))) - (dolist (prop '(:autoload :alias :partial :hide)) - (cl-remf plist prop)) - (puthash (delq nil (cons type target)) - (make-doom-cli - :command target - :type type - :docs (doom-cli--parse-docs (or ',docstring docs)) - :arguments ',arguments - :options ',(nreverse options) - :autoload autoload - :alias (if alias (doom-cli-command-normalize alias plist)) - :plist (append plist (list :hide (and (or hide type) t))) - :fn (unless (or partial autoload) fn)) - doom-cli--table) - (let ((docs (doom-cli--parse-docs docs))) - (dolist (alias (cl-loop for c in commands - while (= (length c) (length target)) - collect (pop commands))) - (puthash (delq nil (cons type alias)) - (make-doom-cli - :command alias - :type type - :docs docs - :autoload autoload - :alias (unless autoload (delq nil (cons type target))) - :plist (append plist '(:hide t))) - doom-cli--table)) - (dolist (partial commands) - (let ((cli (gethash partial doom-cli--table))) - (when (or (null cli) (doom-cli-autoload cli)) - (puthash (delq nil (cons type partial)) - (make-doom-cli - :command partial - :type type - :docs docs - :plist (list :group (plist-get plist :group))) - doom-cli--table))))) - target)))))) - -(defmacro defcli-alias! (commandspec target &rest plist) - "Define a CLI alias for TARGET at COMMANDSPEC. - -See `defcli!' for information about COMMANDSPEC. -TARGET is not a command specification, and should be a command list." - `(defcli! ,commandspec () :alias ',target ,@plist)) - -(defmacro defcli-obsolete! (commandspec target when) - "Define an obsolete CLI COMMANDSPEC that refers users to NEW-COMMAND. - -See `defcli!' for information about COMMANDSPEC. -TARGET is simply a command list. -WHEN specifies what version this command was rendered obsolete." - `(let ((ncommand (doom-cli-command-normalize (backquote ,target) doom-cli--group-plist))) - (defcli! ,commandspec (&context _context &cli cli &rest args) - :docs (format "An obsolete alias for '%s'." (doom-cli-command-string ncommand)) - :hide t - (print! (warn "'%s' was deprecated in %s") - (doom-cli-command-string cli) - ,when) - (print! (warn "It will eventually be removed; use '%s' instead.") - (doom-cli-command-string ncommand)) - (call! ',target args)))) - -(defmacro defcli-stub! (commandspec &optional _argspec &rest body) - "Define a stub CLI, which will throw an error if invoked. - -Use this to define commands that will eventually be implemented, but haven't -yet. They won't be included in command listings (by help documentation)." - (declare (indent 2) (doc-string 3)) - `(defcli! ,commandspec (&rest _) - ,(concat "THIS COMMAND IS A STUB AND HAS NOT BEEN IMPLEMENTED YET." - (if (stringp (car body)) (concat "\n\n" (pop body)))) - :hide t - (user-error "Command not implemented yet"))) - -(defmacro defcli-autoload! (commandspec &optional path &rest plist) - "Defer loading of PATHS until PREFIX is called." - `(let* ((doom-cli--group-plist (append (list ,@plist) doom-cli--group-plist)) - (commandspec (doom-cli-command-normalize ',commandspec)) - (commands (doom-cli--command-expand commandspec)) - (path (or ,path - (when-let* ((cmd (car commands)) - (last (car (last cmd))) - (last (if (listp last) (car last) last))) - (format "%s" last)) - (error "Failed to deduce autoload path for: %s" spec))) - (cli (doom-cli-get (car commands) nil t))) - (when (or (null cli) - (doom-cli-autoload cli)) - (defcli! ,commandspec () :autoload path)))) - -(defmacro defcli-group! (&rest body) - "Declare common properties for any CLI commands defined in BODY." - (when (stringp (car body)) - (push :group body)) - `(let ((doom-cli--group-plist (copy-sequence doom-cli--group-plist))) - ,@(let (forms) - (while (keywordp (car body)) - (let ((key (pop body)) - (val (pop body))) - (push `(cl-callf plist-put doom-cli--group-plist - ,key ,(if (eq key :prefix) - `(append (plist-get doom-cli--group-plist ,key) - (ensure-list ,val)) - val)) - forms))) - (nreverse forms)) - ,@body)) - -(defun exit! (&rest args) - "Exits the current CLI session. - -With ARGS, you may specify a shell command or action (see -`doom-cli-exit-commands') to execute after this Emacs process has ended. For -example: - - (exit! \"$@\") or (exit! :restart) - This reruns the current command with the same arguments. - (exit! \"$@ -h -c\") - This reruns the current command with two new switches. - (exit! :restart \"-c\" :omit \"--foo=2\" \"--bar\") - This reruns the current command with one new switch (-c) and two switches - removed (--foo plus two arguments and --bar). - (exit! \"emacs -nw FILE\") - Opens Emacs on FILE - (exit! \"emacs\" \"-nw\" \"FILE\") - Opens Emacs on FILE, but each argument is escaped (and nils are ignored). - (exit! t) or (exit! nil) - A safe way to simply abort back to the shell with exit code 0 - (exit! 42) - Abort to shell with an explicit exit code. - (exit! context) - Restarts the current session, but with context (a `doom-cli-context' struct). - (exit! :pager [FILES...]) - Invoke $DOOMPAGER (or less) on the output of this session. If ARGS are given, launch the pager on those - (exit! :pager? [FILES...]) - Same as :pager, but does so only if output is longer than the terminal is - tall. - -See `doom-cli--restart' for implementation details." - (throw 'exit (flatten-list args))) - -(defun call! (&rest command) - "A convenience wrapper around `doom-cli-call'. - -Implicitly resolves COMMAND relative to the running CLI, and uses the active -context (so you don't have to pass a context)." - (doom-cli-call (doom-cli-command-normalize - (flatten-list command) - `(:prefix - ,(doom-cli-context-prefix doom-cli--context) - ,@(doom-cli-context-command doom-cli--context))) - doom-cli--context)) - -(defun run! (prefix &rest args) - "Parse and execute ARGS. - -This is the entry point for any shell script that rely on Doom's CLI framework. -It should be called once, at top-level, and never again (use `doom-cli-call' for -nested calls instead). - -PREFIX is the name (string) of the top-level shell script (i.e. $0). All -commands that belong to this shell session should use PREFIX as the first -segment in their command paths. - -ARGS is a list of string arguments to execute. - -See bin/doom's shebang for an example of what state needs to be initialized for -Doom's CLI framework. In a nutshell, Doom is expecting the following environment -variables to be set: - - __DOOMGEOM The dimensions of the current terminal (W . H) - __DOOMPIPE Must contain 0 if script is being piped into, 1 if piping it out - __DOOMGPIPE Like __DOOMPIPE, but is the pipe state of the super process - __DOOMPID A unique ID for this session and its exit script processes - __DOOMSTEP How many layers deep this session has gotten - -The script should also execute ${temporary-file-directory}/doom.sh if Emacs -exits with code 254. This script is auto-generated as needed, to simulate exec -syscalls. See `doom-cli--restart' for technical details. - -Once done, this function kills Emacs gracefully and writes output to log files -(stdout to `doom-cli--output-file', stderr to `doom-cli-debug-file', and any -errors to `doom-cli-error-file')." - (when doom-cli--context - (error "Cannot nest `run!' calls")) - (doom-run-hooks 'doom-after-init-hook) - (with-doom-context 'cli - (let* ((args (flatten-list args)) - (context (make-doom-cli-context :prefix prefix :whole args)) - (doom-cli--context context) - (write-logs-fn (doom-partial #'doom-cli--output-write-logs-h context)) - (show-benchmark-fn (doom-partial #'doom-cli--output-benchmark-h context))) - ;; Clone output to stdout/stderr buffers for logging. - (doom-cli-redirect-output context - (doom-log "run!: %s %s" prefix (combine-and-quote-strings args)) - (add-hook 'kill-emacs-hook show-benchmark-fn 94) - (add-hook 'kill-emacs-hook write-logs-fn 95) - (when (doom-cli-context-pipe-p context :out t) - (setq doom-print-backend nil)) - (when (doom-cli-context-pipe-p context :in) - (with-current-buffer (doom-cli-context-stdin context) - (while (if-let (in (ignore-errors (read-from-minibuffer ""))) - (insert in "\n") - (ignore-errors (delete-char -1)))))) - (doom-cli--exit - (catch 'exit - (condition-case e - (let* ((args (cons (if (getenv "__DOOMDUMP") :dump prefix) args)) - (context (doom-cli-context-restore (getenv "__DOOMCONTEXT") context)) - (context (doom-cli-context-parse args context))) - (run-hook-with-args 'doom-cli-before-run-functions context) - (let ((result (doom-cli-context-execute context))) - (run-hook-with-args 'doom-cli-after-run-functions context result)) - 0) - (doom-cli-wrong-number-of-arguments-error - (pcase-let ((`(,command ,flag ,args ,min ,max) (cdr e))) - (print! (red "Error: %S expected %s argument%s, but got %d") - (or flag (doom-cli-command-string - (if (keywordp (car command)) - command - (cdr command)))) - (if (or (= min max) - (= max most-positive-fixnum)) - min - (format "%d-%d" min max)) - (if (or (= min 0) (> min 1)) "s" "") - (length args)) - (doom-cli-call `(:help "--synopsis" "--postamble" ,@(cdr (doom-cli--command context))) context e)) - 5) - (doom-cli-unrecognized-option-error - (print! (red "Error: unknown option %s") (cadr e)) - (doom-cli-call `(:help "--synopsis" "--postamble" ,@(cdr (doom-cli--command context))) context e) - 5) - (doom-cli-invalid-option-error - (pcase-let ((`(,types ,option ,value ,errors) (cdr e))) - (print! (red "Error: %s received invalid value %S") - (string-join (doom-cli-option-switches option) "/") - value) - (print! (bold "\nValidation errors:")) - (dolist (err errors) (print! (item "%s." (fill err))))) - (doom-cli-call `(:help "--postamble" ,@(cdr (doom-cli--command context))) context e) - 5) - (doom-cli-command-not-found-error - (let* ((command (cdr e)) - (cli (doom-cli-get command))) - (cond ((null cli) - (print! (red "Error: unrecognized command '%s'") - (doom-cli-command-string (or (cdr command) command))) - (doom-cli-call `(:help "--similar" "--postamble" ,@(cdr command)) context e)) - ((null (doom-cli-fn cli)) - (print! (red "Error: a subcommand is required")) - (doom-cli-call `(:help "--subcommands" "--postamble" ,@(cdr command)) context e)))) - 4) - (doom-cli-invalid-prefix-error - (let ((prefix (cadr e))) - (print! (red "Error: `run!' called with invalid prefix %S") prefix) - (if-let (suggested (cl-loop for cli being the hash-value of doom-cli--table - unless (doom-cli-type cli) - return (car (doom-cli-command cli)))) - (print! "Did you mean %S?" suggested) - (print! "There are no commands defined under %S." prefix))) - 4) - (user-error - (print! (red "Error: %s") (cadr e)) - (print! "\nAborting...") - 3))) - context))))) - -(defalias 'sh! #'doom-call-process) - -(defalias 'sh!! #'doom-exec-process) - -;; TODO Make `git!' into a more sophisticated wrapper around git -(defalias 'git! (doom-partial #'straight--process-run "git")) - -(defun get! (key) (doom-cli-context-get doom-cli--context key)) - -(defun put! (key val) (doom-cli-context-put doom-cli--context key val)) - - -;; -;;; doom-cli-help -;; -;; 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: -;; -;; (defcli-alias! (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-help (cli) - "Return an alist of documentation summarizing CLI (a `doom-cli')." - (let* ((rcli (doom-cli-get cli)) - (docs (doom-cli-docs rcli))) - `((command . ,(doom-cli-command-string cli)) - (summary . ,(or (cdr (assoc "SUMMARY" docs)) "[TODO]")) - (description . ,(or (cdr (assoc "MAIN" docs)) "")) - (synopsis . ,(doom-cli-help--synopsis cli)) - (arguments . ,(doom-cli-help--arguments rcli)) - (options . ,(doom-cli-help--options rcli)) - (commands . ,(doom-cli-subcommands cli 1)) - (sections . ,(seq-filter #'cdr (cddr docs)))))) - -(defun doom-cli-help-similar-commands (command &optional maxscore) - "Return N commands that are similar to COMMAND." - (seq-take-while - (fn! (>= (car %) (or maxscore 0.0))) - (seq-sort-by - #'car #'> - (cl-loop with prefix = (seq-find #'doom-cli-get (nreverse (doom-cli--command-expand command t))) - with input = (doom-cli-command-string (cdr (doom-cli--command command t))) - for command in (hash-table-keys doom-cli--table) - if (doom-cli-fn (doom-cli-get command)) - if (equal prefix (seq-take command (length prefix))) - collect (cons (doom-cli-help--similarity - input (doom-cli-command-string (cdr command))) - command))))) - -(defun doom-cli-help--similarity (a b) - (- 1 (/ (float (doom-cli-help--string-distance a b)) - (max (length a) (length b))))) - -(defun doom-cli-help--string-distance (a b) - "Calculate the Restricted Damerau-Levenshtein distance between A and B. -This is also known as the Optimal String Alignment algorithm. - -It is assumed that A and B are both strings, and before processing both are -converted to lowercase. - -This returns the minimum number of edits required to transform A -to B, where each edit is a deletion, insertion, substitution, or -transposition of a character, with the restriction that no -substring is edited more than once." - (let ((a (downcase a)) - (b (downcase b)) - (alen (length a)) - (blen (length b)) - (start 0)) - (when (> alen blen) - (let ((c a) - (clen alen)) - (setq a b alen blen - b c blen clen))) - (while (and (< start (min alen blen)) - (= (aref a start) (aref b start))) - (cl-incf start)) - (cl-decf start) - (if (= (1+ start) alen) - (- blen start) - (let ((v0 (make-vector (- blen start) 0)) - (v1 (make-vector (- blen start) 0)) - (a_i (aref a (max 0 start))) - (current 0) - a_i-1 b_j b_j-1 - left transition-next - above this-transition) - (dotimes (vi (length v0)) - (aset v0 vi (1+ vi))) - (dolist (i (number-sequence (1+ start) (1- alen))) - (setq a_i-1 a_i - a_i (aref a i) - b_j (aref b (max 0 start)) - left (- i start 1) - current (- i start) - transition-next 0) - (dolist (j (number-sequence (1+ start) (1- blen))) - (setq b_j-1 b_j - b_j (aref b j) - above current - current left - this-transition transition-next - transition-next (aref v1 (- j start))) - (aset v1 (- j start) current) - (setq left (aref v0 (- j start))) - (unless (= a_i b_j) - ;; Minimum between substitution, deletion, and insertion - (setq current (min (1+ current) (1+ above) (1+ left))) - (when (and (> i (1+ start)) (> j (1+ start)) (= a_i b_j-1) (= a_i-1 b_j)) - (setq current (min current (cl-incf this-transition))))) - (aset v0 (- j start) current))) - current)))) - -;;; 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 .command " - " .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)) noglobal?) - `(,(assq 'local .options)) - .options) - cli)))) - (command (doom-cli-command cli))) - (letf! (defun printsection (section) - (print! "%s\n" - (if (null section) - (dark "TODO") - (markup - (format-spec - section `((?p . ,(car command)) - (?c . ,(doom-cli-command-string (cdr command)))) - 'ignore))))) - (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* ((rcli (doom-cli-get cli)) - (opts (doom-cli-help--options rcli)) - (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 rcli)) - (subcommands? (doom-cli-subcommands rcli 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))))))) - -(defun doom-cli-help--render-synopsis (synopsis &optional prefix) - (let-alist synopsis - (let ((doom-print-indent 0) - (prefix (or prefix "")) - (command (doom-cli-command-string .command))) - (string-trim-right - (format! "%s\n\n" - (fill (concat (bold prefix) - (format "%s " command) - (markup - (join (append .options - (and .options - (or .required - .optional - .rest) - (list (dark "[--]"))) - .required - .optional - .rest)))) - 80 (1+ (length (concat prefix command))))))))) - -;;; 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))) - (nreverse commands))) - (toplevel (assq nil commands)) - (rest (remove toplevel commands)) - (drop (if prefix (length prefix) 0)) - (minwidth - (apply - #'max (or (cl-loop for cmd in (apply #'append (mapcar #'cdr commands)) - for cmd = (seq-drop cmd drop) - collect (length (doom-cli-command-string cmd))) - (list 15)))) - (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 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 'doom-cli-lib) -;;; doom-cli-lib.el ends here. diff --git a/lisp/doom-cli.el b/lisp/doom-cli.el index 1a22fafa1..648e14191 100644 --- a/lisp/doom-cli.el +++ b/lisp/doom-cli.el @@ -7,75 +7,2354 @@ ;; ;;; Code: -(unless noninteractive - (error "Don't load doom-cli in an interactive session!")) +(defgroup doom-cli nil + "Doom's command-line interface framework." + :link '(url-link "https://doomemacs.org/cli") + :group 'doom) -;; PERF: Deferring the GC in non-interactive sessions isn't as important, but -;; still yields a notable benefit. Still, avoid setting it to high here, as -;; runaway memory usage is a real risk in longer sessions. -(setq gc-cons-threshold 134217728 ; 128mb - ;; Backported from 29 (see emacs-mirror/emacs@73a384a98698) - gc-cons-percentage 1.0) +(defcustom doom-cli-load-path + (append (when-let ((doompath (getenv "DOOMPATH"))) + (cl-loop for dir in (split-string doompath path-separator) + collect (expand-file-name dir))) + (list (file-name-concat (dir!) "cli"))) + "A list of paths to search for autoloaded Doom CLIs. -;; REVIEW: Remove these later. The endpoints should be responsibile for -;; ensuring they exist. For now, they exist to quell file errors. -(with-file-modes #o700 - (mapc (doom-rpartial #'make-directory 'parents) - (list doom-local-dir - doom-data-dir - doom-cache-dir - doom-state-dir))) +It is prefilled by the DOOMPATH envvar (a colon-separated list on Linux/macOS, +semicolon otherwise)." + :type '(list directory) + :group 'doom-cli) -;; HACK: bin/doom suppresses loading of site files so they can be loaded -;; manually, here. Why? To suppress the otherwise unavoidable output they -;; commonly produce (like deprecation notices, file-loaded messages, and -;; linter warnings). This output pollutes the output of doom's CLI (or -;; scripts derived from it) with potentially confusing or alarming -- but -;; always unimportant -- information to the user. -(quiet! - (require 'cl nil t) ; "Package cl is deprecated" - (unless site-run-file ; unset in doom.el - (when-let ((site-run-file (get 'site-run-file 'initial-value))) - (load site-run-file t inhibit-message)))) -(setq-default - ;; PERF: Don't generate superfluous files when writing temp buffers. - make-backup-files nil - ;; COMPAT: Stop user configuration from interfering with package management. - enable-dir-local-variables nil - ;; PERF: Reduce ambiguity, embrace specificity, enjoy predictability. - case-fold-search nil - ;; UX: Don't clog the user's trash with our CLI refuse. - delete-by-moving-to-trash nil) +;; +;;; CLI definition variables -;; Load just the... bear necessities~ -(require 'seq) -(require 'map) +(defvar doom-cli-argument-types + '(&args + &cli + &context + &flags + &multiple + &optional + &rest + &required + &input + &whole) + "A list of auxiliary keywords allowed in `defcli!'s arglist. -;; Suppress any possible coding system prompts during CLI sessions. -(set-language-environment "UTF-8") +See `defcli!' for documentation on them.") -;; Load and set up our debugger first, so backtraces can be made more -;; presentable and logged to file. -(doom-require 'doom-lib 'debug) -(if init-file-debug (doom-debug-mode +1)) +(defvar doom-cli-option-types + '((&flag . &flags) + (&multi . &multiple)) + "An alist of auxiliary keywords permitted in option specs in `defcli!'. -;; Then load the rest of Doom's libs eagerly, since autoloads may not be -;; generated/loaded yet. -(doom-require 'doom-lib 'process) -(doom-require 'doom-lib 'system) -(doom-require 'doom-lib 'git) -(doom-require 'doom-lib 'plist) -(doom-require 'doom-lib 'files) -(doom-require 'doom-lib 'print) -(doom-require 'doom-lib 'autoloads) +They serve as shorter, inline aliases for `doom-cli-argument-types'. -;; Ensure straight and core packages are ready to go for CLI commands. -(require 'doom-cli-lib) -;; Last minute initialization at the end of loading this file. -(with-eval-after-load 'doom-cli - (doom-run-hooks 'doom-before-init-hook)) +See `defcli!' for documentation on them.") +(defvar doom-cli-option-generators + '((&flags . doom-cli--make-option-flag) + (&multiple . doom-cli--make-option-multi) + (&required . doom-cli--make-option-generic) + (&optional . doom-cli--make-option-generic)) + "An alist of `doom-cli-option' factories for argument types. + +Types that + +See argument types in `doom-cli-argument-types', and `defcli!' for usage.") + +(defvar doom-cli-option-arg-types + `((dir :test file-directory-p + :read expand-file-name + :error "Not a valid path to an existing directory" + :zshcomp "_dirs") + (file :test file-exists-p + :read expand-file-name + :error "Not a valid path to an existing file" + :zshcomp "_files") + (stdout :test ,(lambda (str) (equal str "-")) + :read identity + :error "Not a dash to signal stdout" + :zshcomp "(-)") + (path :read expand-file-name :zshcomp "_files") + (form :read read) + (regexp :test ,(lambda (str) (always (string-match-p str "")))) + (int :test "^[0-9]+$" + :read string-to-number + :error "Not an integer") + (num :test "^[0-9]+\\(\\.[0-9]+\\)?$" + :read string-to-number + :error "Not a valid number or float") + (float :test "^[0-9]+\\(\\.[0-9]+\\)$" + :read string-to-number + :error "Not a float") + (bool :test "^y\\(?:es\\)?\\|no?\\|on\\|off\\|t\\(?:rue\\)?\\|false\\|[01]\\|$" + :read ,(lambda (x) + (pcase x + ((or "y" "yes" "t" "true" "1" "on") :yes) + ((or "n" "no" "nil" "false" "0" "off") :no))) + :error "Not a valid boolean, should be blank or one of: yes, no, y, n, true, false, on, off" + :zshcomp "(y n yes no true false on off 1 0)") + (date :test ,(lambda (str) + (let ((ts (parse-time-string str))) + (and (decoded-time-day ts) + (decoded-time-month ts) + (decoded-time-year ts)))) + :read parse-time-string + :error "Not a valid date (try YYYY-MM-DD or a date produced by `date')") + (time :test ,(lambda (str) + (let ((ts (parse-time-string str))) + (and (decoded-time-hour ts) + (decoded-time-minute ts) + (decoded-time-second ts)))) + :read parse-time-string + :error "Not a valid date (try YYYY-MM-DD or a date produced by `date')") + (duration :test ,(lambda (str) + (not (cl-loop for d in (split-string-and-unquote str " ") + unless (string-match-p "^[0-9]+[hmsdMY]$" d) + return t))) + :read ,(doom-rpartial #'split-string-and-unquote " ") + :error "Not a valid duration (e.g. 5h 20m 40s 2Y 1M)") + (size :test "^[0-9]+[kmgt]?b$" + :read ,(lambda (str) + (save-match-data + (and (string-match "^\\([0-9]+\\(?:\\.[0-9]+\\)\\)\\([kmgt]?b\\)$" str) + (* (string-to-number (match-string 1 str)) + (or (cdr (assoc (match-string 2 str) + '(("kb" . 1000) + ("mb" . 1000000) + ("gb" . 1000000000) + ("tb" . 1000000000000)))) + 1))))) + :error "Not a valid filesize (e.g. 5mb 10.4kb 2gb 1.4tb)")) + "A list of implicit option argument datatypes and their rules. + +Recognizies the following properies: + + :test FN + Predicate function to determine if a value is valid. + :read FN + A transformer that converts the string argument to a desired format. + :error STR + The message to display if a value fails :test.") + +;;; Post-script settings +(defvar doom-cli-exit-commands + '(;; (:editor . doom-cli--exit-editor) + ;; (:emacs . doom-cli--exit-emacs) + (:pager . doom-cli--exit-pager) + (:pager? . doom-cli--exit-pager-maybe) + (:restart . doom-cli--exit-restart)) + "An alist of commands that `doom-cli--exit' recognizes.") + +(defcustom doom-cli-pager (getenv "DOOMPAGER") + "The PAGER command to use. + +If nil, falls back to less." + :type 'string + :group 'doom-cli) + +(defcustom doom-cli-pager-ratio 1.0 + "If output exceeds TTY height times this ratio, the pager is invoked. + +Only applies if (exit! :pager) or (exit! :pager?) are called." + :type 'float + :group 'doom-cli) + +;;; Logger settings +(defvar doom-cli-log-file-format (expand-file-name "logs/cli.%s.%s.%s" doom-state-dir) + "Where to write any output/log file to. + +Must have two arguments, one for session id and the other for log type.") + +(defvar doom-cli-log-retain 12 + "Number of each log type to retain.") + +(defvar doom-cli-log-backtrace-depth 12 + "How many frames of the backtrace to display in stdout.") + +(defvar doom-cli-log-straight-error-lines 16 + "How many lines of straight.el errors to display in stdout.") + +(defvar doom-cli-log-benchmark-threshold 5 + "How much execution time (in seconds) before benchmark is shown. + +If set to nil, only display benchmark if a CLI explicitly requested with a +non-nil :benchmark property. +If set to `always', show the benchmark no matter what.") + +(defvar doom-cli-shell + (pcase (getenv "__DOOMSH") + ("ps1" 'pwsh) + (_ 'sh)) + "What shell environment Doom has been started with. + +Can be `pwsh' if invoked via bin/doom.ps1, or `sh' in unix environments.") + +;;; Internal variables +(defvar doom-cli--context nil) +(defvar doom-cli--exit-code 255) +(defvar doom-cli--group-plist nil) +(defvar doom-cli--table (make-hash-table :test 'equal)) + + +;; +;;; Custom hooks + +(defcustom doom-cli-initialize-hook () + "TODO" + :type 'hook + :group 'doom-cli) + +(defcustom doom-cli-create-context-functions () + "A hook executed once a new context has been generated. + +Called by `doom-cli-context-parse' and `doom-cli-context-restore', once a +`doom-cli-context' is fully populated and ready to be executed (but before it +has). + +Hooks are run with one argument: the newly created context." + :type 'hook + :group 'doom-cli) + +(defcustom doom-cli-before-run-functions () + "Hooks run before `run!' executes the command. + +Runs with a single argument: the active context (a `doom-cli-context' struct)." + :type 'hook + :group 'doom-cli) + +(defcustom doom-cli-after-run-functions () + "Hooks run after `run!' has executed the command. + +Runs with two arguments: the active context (a `doom-cli-context' struct) and +the return value of the executed CLI." + :type 'hook + :group 'doom-cli) + + +;; +;;; Errors + +(define-error 'doom-cli-definition-error "Invalid CLI definition" 'doom-cli-error) +(define-error 'doom-cli-autoload-error "Failed to autoload deferred command" 'doom-cli-error) +(define-error 'doom-cli-invalid-prefix-error "Prefix has no defined commands" 'doom-cli-error) +(define-error 'doom-cli-command-not-found-error "Could not find that command" 'doom-cli-error) +(define-error 'doom-cli-wrong-number-of-arguments-error "Wrong number of CLI arguments" 'doom-cli-error) +(define-error 'doom-cli-unrecognized-option-error "Not a recognized option" 'doom-cli-error) +(define-error 'doom-cli-invalid-option-error "Invalid option value" 'doom-cli-error) + + +;; +;;; `doom-cli' + +(cl-defstruct doom-cli + "An executable CLI command." + (command nil :read-only t) + type + docs + autoload + alias + options + arguments + plist + fn) + +(defun doom-cli-execute (cli bindings) + "Execute CLI with BINDINGS (an alist). + +BINDINGS is an alist of (SYMBOL . VALUE) to bind lexically during CLI's +execution. Can be generated from a `doom-cli-context' with +`doom-cli--bindings'." + (doom-log "execute: %s %s" (doom-cli-key cli) bindings) + (funcall (doom-cli-fn cli) cli bindings)) + +(defun doom-cli-key (cli) + "Return CLI's (type . command), used as a table key or unique identifier." + (let ((command (doom-cli-command cli))) + (if-let (type (doom-cli-type cli)) + (cons type command) + command))) + +(defun doom-cli-command-normalize (command &optional plist) + "Ensure that COMMAND is properly formatted. + +This means that all non-keywords are strings, any prefixes provided by PLIST are +prepended, and the keyword is in front." + (let* ((command (ensure-list command)) + (prefix (plist-get plist :prefix)) + (prefix (if prefix (doom-cli-command-normalize + prefix (append `(:prefix nil) plist)))) + (command (append prefix command)) + (type (cl-find-if #'keywordp (remq :root command) :from-end t)) + (command (seq-subseq + command (or (cl-position :root command :from-end t) + 0)))) + (when (or command prefix) + (cl-loop with map = (fn! (if (or (stringp %) (keywordp %)) % (prin1-to-string %))) + for c in (delq nil (cons type (seq-remove #'keywordp command))) + if (listp c) + collect (mapcar map c) + else collect (funcall map c))))) + +(defun doom-cli-command-string (command) + "Return a joined string representation of normalized COMMAND. + +COMMAND should either be a command list (e.g. '(doom foo bar)) or a `doom-cli' +struct." + (mapconcat (doom-partial #'format "%s") + (doom-cli--command command) + " ")) + +(defun doom-cli-get (command &optional noresolve? noload?) + "Return CLI at COMMAND. + +Will autoload COMMAND if it was deferred with `defcli-autoload!'. + +If NORESOLVE?, don't follow aliases." + (when-let* ((command (doom-cli--command command)) + (cli (gethash command doom-cli--table)) + (cli (if noload? cli (doom-cli-load cli)))) + (if noresolve? + cli + (let (path) + (while (setq path (ignore-errors (doom-cli-alias cli))) + (setq cli (doom-cli-get path t noload?))) + (unless cli + (signal 'doom-cli-command-not-found-error (or path command))) + cli)))) + +(defun doom-cli-path (cli &optional noload?) + "Return a list of `doom-cli's encountered while following CLI's aliases. + +If NOLOAD? is non-nil, don't autoload deferred CLIs (see `doom-cli-get')." + (when cli + (cons + cli (let (alias paths) + (while (setq alias (ignore-errors (doom-cli-alias cli))) + (and (setq cli (doom-cli-get alias t noload?)) + (push cli paths))) + (nreverse paths))))) + +(defun doom-cli-find (command &optional nopartials?) + "Find all CLIs assocated with COMMAND, including partials. + +COMMAND can be a command path (list of strings), a `doom-cli' struct, or a +`doom-cli-context' struct. + +Returned in the order they will execute. Includes pseudo CLIs." + (let* ((command (doom-cli--command command)) + (paths (nreverse (doom-cli--command-expand command t))) + results clis) + (push '(:after) results) + (dolist (path paths) + (push (cons :after path) results)) + (push command results) + (dolist (path (nreverse paths)) + (push (cons :before path) results)) + (push '(:before) results) + (dolist (result results (nreverse clis)) + (when-let ((cli (doom-cli-get result t)) + ((or (not nopartials?) + (doom-cli-type cli)))) + (cl-pushnew cli clis + :test #'equal + :key #'doom-cli-key))))) + +(defun doom-cli-prop (cli prop &optional null-value) + "Returns a PROPerty of CLI's plist, or NULL-VALUE if it doesn't exist." + (let ((plist (doom-cli-plist cli))) + (if (plist-member plist prop) + (plist-get plist prop) + null-value))) + +(cl-defun doom-cli-subcommands (command &optional (depth 9999) &key tree? all? predicate?) + "Return a list of subcommands, DEPTH levels deep, below COMMAND. + + If DEPTH is non-nil, list *all* subcommands, recursively. Otherwise it expects +an integer. + If TREE?, return commands in a tree structure. + If ALL?, include hidden commands (like aliases)." + (when (or (null depth) (> depth 0)) + (catch :predicate + (let* ((command (doom-cli--command command t)) + (prefixlen (length command)) + results) + (dolist (cli (hash-table-values doom-cli--table)) + (let ((clicmd (doom-cli-command cli))) + (when (and (not (doom-cli-type cli)) + (= (length clicmd) (1+ prefixlen)) + (equal command (seq-take clicmd prefixlen)) + (or all? (not (doom-cli-prop cli :hide)))) + (when predicate? + (throw :predicate t)) + (let* ((car (if tree? (car (last clicmd)) clicmd)) + (cdr (doom-cli-subcommands + clicmd (if depth (1- depth)) + :tree? tree? + :all? all?))) + (if tree? + (push (if cdr (cons car cdr) car) results) + (cl-callf nconc results (cons car cdr))))))) + (if tree? + (nreverse results) + results))))) + +(defun doom-cli-aliases (cli) + "Return all known `doom-cli's that are aliased to CLI. + +This cannot see autoloaded CLIs. Use `doom-cli-load' or `doom-cli-load-all' +to reach them." + (cl-loop with cli = (doom-cli-get cli) + with key = (doom-cli-key cli) + for rcli in (hash-table-values doom-cli--table) + if (equal key (doom-cli-key rcli)) + collect cli)) + +(defun doom-cli-short-docs (cli) + "Return the first line of CLI's documentation. + +Return nil if CLI (a `doom-cli') has no explicit documentation." + (ignore-errors (cdr (assoc "SUMMARY" (doom-cli-docs cli))))) + +(defun doom-cli--bindings (cli context &optional seen) + "Return a CLI with a value alist in a cons cell." + (let* ((optspec (doom-cli-options cli)) + (argspec (doom-cli-arguments cli)) + alist) + ;; Ensure all symbols are defined + (dolist (opt optspec) + (setf (alist-get (doom-cli-option-symbol opt) alist) + (doom-cli-option-default opt))) + (dolist (syms argspec) + (dolist (sym (cdr syms)) + (setf (alist-get sym alist) nil))) + ;; Populate options + (let ((options (doom-cli-context-options context))) + (dolist (opt optspec) + (when-let (option (cl-loop for flag in (doom-cli-option-switches opt) + if (cdr (assoc flag options)) + return (cons flag it))) + (unless (member (car option) seen) + (setf (alist-get (doom-cli-option-symbol opt) alist) + (cdr option)) + (push (car option) seen))))) + ;; Populate arguments + (let* ((arglist (doom-cli-context-arguments context)) + (rest (copy-sequence (map-elt arglist (doom-cli-command cli)))) + (args (copy-sequence (alist-get t arglist))) + (argc (length args)) + (required (alist-get '&required argspec)) + (optional (alist-get '&optional argspec)) + (spec (append required optional)) + (min (length required)) + (max (if (or (assq '&args argspec) + (assq '&rest argspec)) + most-positive-fixnum + (length spec)))) + (when (or (< argc min) + (> argc max)) + (signal 'doom-cli-wrong-number-of-arguments-error + (list (doom-cli-key cli) nil args min max))) + (dolist (sym spec) + (setf (alist-get sym alist) (if args (pop args)))) + (dolist (type `((&args . ,args) + (&cli . ,cli) + (&context . ,context) + (&input + . ,(if (doom-cli-context-pipe-p context :in t) + (with-current-buffer (doom-cli-context-stdin context) + (buffer-string)))) + (&rest . ,rest) + (&whole . ,(doom-cli-context-whole context)))) + (when-let (var (car (alist-get (car type) argspec))) + (setf (alist-get var alist) (cdr type))))) + alist)) + +(defun doom-cli--command (target &optional notype?) + "Fetch the normalized command from TARGET. + +If NOTYPE? is non-nil, omit any leading keywords from the command. + +TARGET can be a `doom-cli', `doom-cli-context', or a command list." + (cond ((doom-cli-p target) + (if notype? + (doom-cli-command target) + (doom-cli-key target))) + ((doom-cli-context-p target) + (doom-cli-context-command target)) + ((and target (not (listp target))) + (signal 'wrong-type-argument + (list '(doom-cli-p doom-cli-context-p listp) target))) + ((let ((target (doom-cli-command-normalize target))) + (if (and notype? (keywordp (car target))) + (cdr target) + target))))) + +(defun doom-cli--command-expand (commandspec &optional recursive?) + "Expand COMMANDSPEC into a list of commands. + +If RECURSIVE, includes breadcrumbs leading up to COMMANDSPEC." + (funcall (if recursive? + #'identity + (fn! (cl-loop with cmdlen = (length (car %)) + for command in % + while (= (length command) cmdlen) + collect command))) + (seq-reduce (lambda (init next) + (nconc (cl-loop with firstlen = (length (car init)) + for seg in (ensure-list next) + nconc + (cl-loop for command in init + while (= (length command) firstlen) + collect (append command (list seg)))) + init)) + (cdr commandspec) + `(,@(mapcar #'list (ensure-list (car commandspec))))))) + +(defun doom-cli--parse-docs (docs) + (when (and (stringp docs) + (not (equal docs "TODO"))) + (let ((re "^\\([A-Z0-9 _-]+\\):\n") sections) + (with-temp-buffer + (save-excursion + (insert "__DOOMDOCS__:\n") + (insert docs)) + (while (re-search-forward re nil t) + (push (cons (match-string 1) + (let ((buffer (current-buffer)) + (beg (match-end 0)) + (end (save-excursion + (if (re-search-forward re nil t) + (1- (match-beginning 0)) + (point-max))))) + (with-temp-buffer + (insert-buffer-substring buffer beg end) + (goto-char (point-min)) + (indent-rigidly (point-min) (point-max) (- (skip-chars-forward " "))) + (string-trim-right (buffer-string))))) + sections))) + (let ((lines (split-string (cdr (assoc "__DOOMDOCS__" sections)) "\n")) + (sections (assoc-delete-all "__DOOMDOCS__" sections))) + `(("SUMMARY" . ,(car lines)) + ("MAIN" . ,(string-trim (string-join (cdr lines) "\n"))) + ,@(nreverse sections)))))) + + +;; +;;; `doom-cli-option' + +(cl-defstruct doom-cli-option + "A switch specification dictating the characteristics of a recognized option." + (symbol nil :read-only t) + docs + multiple-p + flag-p + switches + arguments + default) + +(defun doom-cli-option-validate (option &rest values) + "Test if OPTION will accept VALUES, and conforms them if necessary. + +OPTION is a `doom-cli-option' struct. VALUES can be any arbitrary values. +Returns VALUES once mapped through their respective reader (as dictated by +`doom-cli-option-arg-types'). + +Throws `doom-cli-invalid-option-error' for illegal values." + (let ((args (doom-cli-option-arguments option)) + (values (copy-sequence values))) + (dotimes (i (length args) values) + (let ((value (nth i values)) + (types (ensure-list (nth i args))) + errors) + (catch 'done + (dolist (type types) + ;; REVIEW Use pcase-let + map.el when 27.x support is dropped + (cl-destructuring-bind (&key test read error &allow-other-keys) + (if (or (symbolp type) + (and (stringp type) + (string-match-p "^[A-Z0-9-_]+$" type))) + (cdr (assq (if (symbolp type) type (intern (downcase type))) + doom-cli-option-arg-types)) + (list 'str :test #'stringp)) + (condition-case-unless-debug e + (or (and (or (null test) + (if (stringp test) + (and (string-match-p test value) t) + (funcall test value))) + (or (null read) + (setf (nth i values) (funcall read value))) + (throw 'done t)) + (push error errors)) + ((invalid-regexp invalid-read-syntax) + (push (error-message-string e) errors))))) + (signal 'doom-cli-invalid-option-error + (list types option value errors))))))) + +(defun doom-cli--read-option-switches (optspec) + (delq + nil (cl-loop for spec in optspec + if (and (stringp spec) + (string-match-p "^-\\(?:-[a-zA-Z0-9]\\|[^-]$\\)" spec)) + collect spec))) + +(defun doom-cli--read-option-args (argspec) + (delq + nil (cl-loop for spec in argspec + if (or (and (stringp spec) + (not (string-match-p "^-\\(?:-[a-zA-Z0-9]\\|[^-]$\\)" spec))) + (keywordp spec) + (symbolp spec) + (listp spec)) + collect spec))) + +(defun doom-cli--make-option-generic (symbol spec &optional docs) + (make-doom-cli-option + :symbol symbol + :docs docs + :switches (doom-cli--read-option-switches spec) + :arguments (doom-cli--read-option-args spec))) + +(defun doom-cli--make-option-flag (symbol spec &optional docs) + (let ((switches (doom-cli--read-option-switches spec)) + (args (doom-cli--read-option-args spec))) + (when (and args + (not (or (memq :yes args) + (memq :no args)))) + (signal 'doom-cli-definition-error + (list "Argument type %s cannot accept arguments for: %s" + '&flag (mapconcat #'symbol-name spec ", ")))) + (make-doom-cli-option + :symbol symbol + :docs docs + :flag-p t + :switches switches + :default (car args)))) + +(defun doom-cli--make-option-multi (symbol spec &optional docs) + (make-doom-cli-option + :symbol symbol + :docs docs + :multiple-p t + :switches (doom-cli--read-option-switches spec) + :arguments (doom-cli--read-option-args spec))) + + +;; +;;; `doom-cli-context' + +(cl-defstruct doom-cli-context + "A CLI context, containing all state pertinent to the current session." + (init-time before-init-time) ; When this context was created + ;; A session-specific ID of the current context (defaults to number + (pid (if-let (pid (getenv "__DOOMPID")) + (string-to-number pid) + (emacs-pid))) + ;; Number of Emacs processes this context has been processed through + (step (if-let (step (getenv "__DOOMSTEP")) + (string-to-number step) + -1)) + ;; The geometry of the terminal window. + (geometry (save-match-data + (when-let* ((geom (getenv "__DOOMGEOM")) + ((string-match "^\\([0-9]+\\)x\\([0-9]+\\)$" geom))) + (cons (string-to-number (match-string 1 geom)) + (string-to-number (match-string 2 geom)))))) + ;; Whether the script is being piped into or out of + (pipes (cl-loop for (env . scope) in `((,(getenv "__DOOMGPIPE") . global) + (,(getenv "__DOOMPIPE") . local)) + if (stringp env) + for pipes = (string-to-list env) + nconc `(,@(if (memq ?0 pipes) `((:in . ,scope))) + ,@(if (memq ?1 pipes) `((:out . ,scope))))) + :skip t) + ;; If non-nil, suppress prompts and auto-accept their consequences. + suppress-prompts-p + (prefix "@") ; The basename of the script creating this context + meta-p ; Whether or not this is a help/meta request + error ; + (command nil :skip t) ; The full command that led to this context + (path nil :skip t) ; Breadcrumb list of resolved commands so far + (whole nil :skip t) ; Unfiltered and unprocessed list of arguments + (options nil :skip t) ; An alist of (flags . value) + (arguments nil :skip t) ; An alist of non-subcommand arguments, by command + (stdin (generate-new-buffer " *doom-cli stdin*") :type buffer) ; buffer containing anything piped into this session + (stdout (generate-new-buffer " *doom-cli stdout*") :type buffer) ; buffer containing user-visible output + (stderr (generate-new-buffer " *doom-cli stderr*") :type buffer) ; buffer containing all output, including debug output + ;; An alist of persistent and arbitrary elisp state + (state nil :type alist)) + +(defun doom-cli-context-execute (context) + "Execute a given CONTEXT. + +Use `doom-cli-context-parse' or `doom-cli-context-restore' to produce a valid, +executable context." + (let* ((command (doom-cli-context-command context)) + (cli (doom-cli-get command t)) + (prefix (doom-cli-context-prefix context))) + (doom-log "context-execute: %s" + (mapconcat #'doom-cli-command-string + (delq nil (list (car (doom-cli-context-path context)) command)) + " -> ")) + (cond ((null (or command (doom-cli-get (list prefix) t))) + (signal 'doom-cli-invalid-prefix-error (list prefix))) + + ((doom-cli-context-meta-p context) + (pcase (doom-cli-context-meta-p context) + ("--version" + (doom-cli-call `(:version ,@(cdr command)) context) + t) + ((or "-?" "--help") + (doom-cli-call `(:help ,@(cdr command)) context) + t) + (_ (error "In meta mode with no destination!")))) + + ((not (and cli (doom-cli-fn (doom-cli-get cli)))) + (signal 'doom-cli-command-not-found-error + (append command (alist-get t (doom-cli-context-arguments context))))) + + ((let ((seen '(t)) + runners) + (dolist (cli (doom-cli-find command (doom-cli-type cli))) + (push (cons (doom-cli-get cli) + (doom-cli--bindings cli context seen)) + runners)) + (pcase-dolist (`(,cli . ,bindings) (nreverse runners)) + (doom-cli-execute cli bindings)) + context))))) + +(defun doom-cli-context-restore (file context) + "Restore the last restarted context from FILE into CONTEXT." + (when (and (stringp file) + (file-exists-p file)) + (when-let (old-context (with-temp-buffer + (insert-file-contents file) + (read (current-buffer)))) + (unless (doom-cli-context-p old-context) + (error "An invalid context was restored from file: %s" file)) + (unless (equal (doom-cli-context-prefix context) + (doom-cli-context-prefix old-context)) + (error "Restored context belongs to another script: %s" + (doom-cli-context-prefix old-context))) + (pcase-dolist (`(,slot ,_ . ,plist) + (cdr (cl-struct-slot-info 'doom-cli-context))) + (unless (plist-get plist :skip) + (let* ((idx (cl-struct-slot-offset 'doom-cli-context slot)) + (old-value (aref old-context idx))) + (aset context idx + (pcase (plist-get plist :type) + (`alist + (dolist (entry old-value (aref context idx)) + (setf (alist-get (car entry) (aref context idx)) (cdr entry)))) + (`buffer + (with-current-buffer (aref context idx) + (insert old-value) + (current-buffer))) + (_ old-value)))))) + (run-hook-with-args 'doom-cli-create-context-functions context) + (delete-file file) + (doom-log "context-restore: %s" (doom-cli-context-pid context)))) + context) + +(defun doom-cli-context-parse (args context) + "Parse ARGS and update CONTEXT to reflect it." + (let* ((case-fold-search t) + (args (delq nil (copy-sequence args))) + (arguments) + rest? + arg) + (while args + (setq arg (pop args)) + (save-match-data + (cond + ((equal arg "--") + (doom-log "context-parse: found arg separator" arg) + (setq arguments (cdr args) + args nil)) + + ((and (stringp arg) + (string-match "^\\(-\\([^-]\\{2,\\}\\)\\)" arg)) + (let ((chars (split-string (match-string 2 arg) "" t))) + (dolist (ch (nreverse chars)) + (push (concat "-" ch) args)))) + + ((and (stringp arg) + (or (string-match "^\\(--\\w[a-z0-9-_]+\\)\\(?:=\\(.*\\)\\)?$" arg) + (string-match "^\\(-[^-]\\)$" arg))) + (doom-log "context-parse: found switch %S" arg) + (catch :skip + (let* ((fullflag (match-string 1 arg)) + (normflag (if (string-prefix-p "--no-" fullflag) + (concat "--" (substring fullflag 5)) + fullflag)) + (option (or (doom-cli-context-find-option context normflag) + (when (member fullflag '("-?" "--help" "--version")) + (doom-log "context-parse: found help switch %S" arg) + (setf (doom-cli-context-meta-p context) fullflag) + (throw :skip t)) + (when rest? + (push arg arguments) + (throw :skip t)) + (signal 'doom-cli-unrecognized-option-error + (list fullflag)))) + (explicit-arg (match-string 2 arg)) + (arity (length (doom-cli-option-arguments option))) + (key (if (doom-cli-option-multiple-p option) + (car (doom-cli-option-switches option)) + normflag))) + (doom-cli-context-put + context key + (let ((value (seq-take args arity))) + (when explicit-arg + (push explicit-arg value)) + (when (/= (length value) arity) + (signal 'doom-cli-wrong-number-of-arguments-error + (list (doom-cli--command context) + fullflag value arity arity))) + (setq args (seq-drop args arity) + value (apply #'doom-cli-option-validate option value)) + (cond ((doom-cli-option-flag-p option) + (if (string-prefix-p "--no-" fullflag) :no :yes)) + ((doom-cli-option-multiple-p option) + (append (doom-cli-context-get context key) + (if (doom-cli-option-arguments option) + (cl-loop for v in value + collect (cons fullflag v)) + (list fullflag)))) + ((= arity 1) (car value)) + ((> arity 1) value) + (fullflag))))))) + + ((when-let* + (((null arguments)) + ((not rest?)) + (command (append (doom-cli-context-command context) (list arg))) + (cli (doom-cli-get command t)) + (rcli (doom-cli-get command)) + (key (doom-cli-key rcli))) + (doom-log "context-parse: found command %s" command) + ;; Show warnings depending on CLI plists + (when (doom-cli-alias cli) + (dolist (pcli (doom-cli-path cli)) + (doom-log "context-parse: path += %s" (doom-cli-key pcli)) + (push (doom-cli-key pcli) (doom-cli-context-path context)))) + ;; Collect &rest for this command + (setf (doom-cli-context-command context) key + (map-elt (doom-cli-context-arguments context) + (doom-cli-command rcli)) + (copy-sequence args)) + ;; Initialize options associated with this command to a nil value; + ;; this simplifies existence validation later. + (dolist (cli (doom-cli-find key)) + (dolist (option (doom-cli-options cli)) + (dolist (switch (doom-cli-option-switches option)) + (unless (assoc switch (doom-cli-context-options context)) + (setf (map-elt (doom-cli-context-options context) switch) + nil))))) + ;; If this command uses &rest, stop processing commands from this + ;; point on and pass the rest (of the unprocessed arguments) to it. + (when (and (doom-cli-fn rcli) + (alist-get '&rest (doom-cli-arguments rcli))) + (setq rest? t)) + t)) + + ((push arg arguments) + (doom-log "context-parse: found arg %S" arg))))) + + (setf (alist-get t (doom-cli-context-arguments context)) + (append (alist-get t (doom-cli-context-arguments context)) + (nreverse arguments))) + (run-hook-with-args 'doom-cli-create-context-functions context) + context)) + +(defun doom-cli-context-get (context key &optional null-value) + "Fetch KEY from CONTEXT's options or state. + +Context objects are essentially persistent storage, and may contain arbitrary +state tied to switches (\"--foo\" or \"-x\") or arbitrary symbols (state). + +If KEY is a string, fetch KEY from context's OPTIONS (by switch). +If KEY is a symbol, fetch KEY from context's STATE. +Return NULL-VALUE if KEY does not exist." + (if-let (value + (if (stringp key) + (assoc key (doom-cli-context-options context)) + (assq key (doom-cli-context-state context)))) + (cdr value) + null-value)) + +(defun doom-cli-context-put (context key val) + "Set KEY in CONTEXT's options or state to VAL. + +Context objects contain persistent storage, and may contain arbitrary state tied +to switches (\"--foo\" or \"-x\") or arbitrary symbols (state). Use this to +register data into CONTEXT. + +If KEY is a string, set the value of a switch named KEY to VAL. +If KEY is a symbol, set the value of the context's STATE to VAL." + (setf (alist-get + key (if (stringp key) + (doom-cli-context-options context) + (doom-cli-context-state context)) + nil nil #'equal) + val)) + +(defun doom-cli-context-find-option (context switch) + "Return a `doom-cli-option' belonging to SWITCH in CONTEXT, if available. + +Returns nil if SWITCH isn't a valid option in CONTEXT or none of the associated +`doom-cli's have a `doom-cli-option' associated with SWITCH." + (when (assoc switch (doom-cli-context-options context)) + (cl-loop with command = (doom-cli-context-command context) + for cli in (doom-cli-find command) + if (seq-find (lambda (opt) + (let ((switches (doom-cli-option-switches opt))) + (or (member switch switches) + (and (doom-cli-option-flag-p opt) + (string-prefix-p "--no-" switch))))) + (doom-cli-options cli)) + return it))) + +(defun doom-cli-context-width (context) + "Return the width (in character units) of CONTEXT's original terminal." + (or (car (doom-cli-context-geometry context)) + 80)) + +(defun doom-cli-context-height (context) + "Return the height (in character units) of CONTEXT's original terminal." + (or (cdr (doom-cli-context-geometry context)) + 40)) + +(defun doom-cli-context-pipe-p (context type &optional global?) + "Return non-nil if TYPE is an active pipe in the local CONTEXT. + +TYPE can be one of `:in' (receiving input on stdin) or `:out' (output is piped +to another process), or any of `local-in', `local-out', `global-in', or +`global-out'. + +If GLOBAL? is non-nil, if TYPE is `:in' or `:out', the global context (the pipes +active in the super-session, rather than the local Emacs instance) will be +considered as well." + (let ((pipes (doom-cli-context-pipes context))) + (and (if global? + (assq type pipes) + (member (cons type 'local) pipes)) + t))) + +(defun doom-cli-context-sid (context &optional nodate?) + "Return a unique session identifier for CONTEXT." + (if nodate? + (doom-cli-context-pid context) + (format (format-time-string + "%y%m%d%H%M%S.%%s" (doom-cli-context-init-time context)) + (doom-cli-context-pid context)))) + + +;; +;;; Output management + +(defun doom-cli-debugger (type data &optional context) + "Print a more presentable backtrace to terminal and write it to file." + ;; HACK Works around a heuristic in eval.c for detecting errors in the + ;; debugger, which executes this handler again on subsequent calls. Taken + ;; from `ert--run-test-debugger'. + (cl-incf num-nonmacro-input-events) + (let* ((inhibit-read-only nil) + (inhibit-message nil) + (inhibit-redisplay nil) + (inhibit-trace t) + (executing-kbd-macro nil) + (load-read-function #'read) + (backtrace (doom-backtrace)) + (context (or context (make-doom-cli-context))) + (straight-error + (and (bound-and-true-p straight-process-buffer) + (or (member straight-process-buffer data) + (string-match-p (regexp-quote straight-process-buffer) + (error-message-string data))) + (with-current-buffer (straight--process-buffer) + (split-string (buffer-string) "\n" t)))) + (error-file (doom-cli--output-file 'error context))) + (cond + (straight-error + (print! (error "The package manager threw an error")) + (print! (error "Last %d lines of straight's error log:") + doom-cli-log-straight-error-lines) + (print-group! + (print! + "%s" (string-join + (seq-subseq straight-error + (max 0 (- (length straight-error) + doom-cli-log-straight-error-lines)) + (length straight-error)) + "\n"))) + (print! (warn "Wrote extended straight log to %s") + (path (let ((coding-system-for-write 'utf-8-auto)) + (with-file-modes #o600 + (with-temp-file error-file + (insert-buffer-substring (straight--process-buffer)))) + error-file)))) + ((eq type 'error) + (let* ((generic? (eq (car data) 'error)) + (doom-cli-log-backtrace-depth doom-cli-log-backtrace-depth) + (print-escape-newlines t)) + (if (doom-cli-context-p context) + (print! (error "There was an unexpected runtime error")) + (print! (bold (error "There was a fatal initialization error")))) + (print-group! + (print! "%s %s" (bold "Message:") + (if generic? + (error-message-string data) + (get (car data) 'error-message))) + (unless generic? + (print! "%s %s" (bold "Details:") + (let* ((print-level 4) + (print-circle t) + (print-escape-newlines t)) + (prin1-to-string (cdr data))))) + (when backtrace + (print! (bold "Backtrace:")) + (print-group! + (dolist (frame (seq-take backtrace doom-cli-log-backtrace-depth)) + (print! "%s" (truncate (prin1-to-string + (cons (backtrace-frame-fun frame) + (backtrace-frame-args frame))) + (- (doom-cli-context-width context) + doom-print-indent + 1) + "...")))) + (when-let (backtrace-file (doom-backtrace-write-to-file backtrace error-file)) + (print! (warn "Wrote extended backtrace to %s") + (path backtrace-file)))))))) + (exit! 255))) + +(defmacro doom-cli-redirect-output (context &rest body) + "Redirect output from BODY to the appropriate log buffers in CONTEXT." + (declare (indent 1)) + (let ((contextsym (make-symbol "doomctxt"))) + `(let* ((,contextsym ,context) + ;; Emit more user-friendly backtraces + (debugger (doom-rpartial #'doom-cli-debugger ,contextsym)) + (debug-on-error t)) + (with-output-to! `((>= notice ,(doom-cli-context-stdout ,contextsym)) + (t . ,(doom-cli-context-stderr ,contextsym))) + ,@body)))) + +(defun doom-cli--output-file (type context) + "Return a log file path for TYPE and CONTEXT. + +See `doom-cli-log-file-format' for details." + (format doom-cli-log-file-format + (doom-cli-context-prefix context) + (doom-cli-context-sid context) + type)) + +(defun doom-cli--output-write-logs-h (context) + "Write all log buffers to their appropriate files." + (when (/= doom-cli--exit-code 254) + ;; Delete the last `doom-cli-log-retain' logs + (mapc #'delete-file + (let ((prefix (doom-cli-context-prefix context))) + (append (butlast (doom-glob (format doom-cli-log-file-format prefix "*" "log")) + doom-cli-log-retain) + (butlast (doom-glob (format doom-cli-log-file-format prefix "*" "error")) + doom-cli-log-retain)))) + ;; Then write the log file, if necessary + (let* ((buffer (doom-cli-context-stderr context)) + (file (doom-cli--output-file "log" context))) + (when (> (buffer-size buffer) 0) + (with-file-modes #o700 + (make-directory (file-name-directory file) t)) + (with-file-modes #o600 + (with-temp-file file + (insert-buffer-substring buffer) + (ansi-color-filter-region (point-min) (point-max)))))))) + +(defun doom-cli--output-benchmark-h (context) + "Write this session's benchmark to stdout or stderr, depending. + +Will also output it to stdout if requested (CLI sets :benchmark to t) or the +command takes >5s to run. If :benchmark is explicitly set to nil (or +`doom-cli-log-benchmark-threshold' is nil), under no condition should a +benchmark be shown." + (doom-cli-redirect-output context + (doom-log "%s (GCs: %d, elapsed: %.6fs)" + (if (= doom-cli--exit-code 254) "Restarted" "Finished") + gcs-done gc-elapsed) + (when-let* ((init-time (doom-cli-context-init-time context)) + (cli (doom-cli-get context)) + (duration (float-time (time-subtract (current-time) init-time))) + (hours (/ (truncate duration) 60 60)) + (minutes (- (/ (truncate duration) 60) (* hours 60))) + (seconds (- duration (* hours 60 60) (* minutes 60)))) + (when (and (/= doom-cli--exit-code 254) + (or (eq (doom-cli-prop cli :benchmark) t) + (eq doom-cli-log-benchmark-threshold 'always) + (and (eq (doom-cli-prop cli :benchmark :null) :null) + (not (doom-cli-context-pipe-p context 'out t)) + (> duration (or doom-cli-log-benchmark-threshold + most-positive-fixnum))))) + (print! (success "Finished in %s") + (join (list (unless (zerop hours) (format "%dh" hours)) + (unless (zerop minutes) (format "%dm" minutes)) + (format (if (> duration 60) "%ds" "%.5fs") + seconds)))))))) + + +;; +;;; Session management + +(defun doom-cli-call (args context &optional error) + "Process ARGS (list of string shell arguments) with CONTEXT as the basis. + +If ERROR is provided, store the error in CONTEXT, in case a later CLI wants to +read/use it (e.g. like a :help CLI)." + (let ((oldcommand (doom-cli-context-command context))) + (if oldcommand + (doom-log "call: %s -> %s" oldcommand args) + (doom-log "call: %s" oldcommand args)) + (when error + (setf (doom-cli-context-error context) error)) + (setf (doom-cli-context-command context) nil + (doom-cli-context-arguments context) nil + (doom-cli-context-meta-p context) nil) + (doom-cli-context-execute + (doom-cli-context-parse args (or context doom-cli--context))))) + +(defun doom-cli--restart (args context) + "Restart the current CLI session. + +If CONTEXT is non-nil, this is written to file and restored in the next Doom +session. + +This is done by writing a temporary shell script, which is executed after this +session ends (see the shebang lines of this file). It's done this way because +Emacs' batch library lacks an implementation of the exec system call." + (cl-check-type context doom-cli-context) + (when (= (doom-cli-context-step context) -1) + (error "__DOOMSTEP envvar missing; extended `exit!' functionality will not work")) + (let* ((pid (doom-cli-context-pid context)) + (step (doom-cli-context-step context)) + (shext (if (eq doom-cli-shell 'pwsh) "ps1" "sh")) + (context-file (format (doom-path temporary-file-directory "doom.%s.%s.context") pid step)) + (script-file (format (doom-path temporary-file-directory "doom.%s.%s.%s") pid step shext)) + (command (if (listp args) (combine-and-quote-strings (remq nil args)) args)) + (persistent-files + (combine-and-quote-strings (delq nil (list script-file context-file)))) + (persisted-env + (cl-remove-if-not + #'cdr (append + `(("DOOMPROFILE" . ,(ignore-errors (doom-profile->id doom-profile))) + ("EMACSDIR" . ,doom-emacs-dir) + ("DOOMDIR" . ,doom-user-dir) + ("DEBUG" . ,(if init-file-debug (number-to-string doom-log-level))) + ("__DOOMPID" . ,(number-to-string (doom-cli-context-pid context))) + ("__DOOMSTEP" . ,(number-to-string (doom-cli-context-step context))) + ("__DOOMCONTEXT" . ,context-file)) + (save-match-data + (cl-loop with initial-env = (get 'process-environment 'initial-value) + for env in (seq-difference process-environment initial-env) + if (string-match "^\\([a-zA-Z0-9_][^=]+\\)=\\(.+\\)$" env) + collect (cons (match-string 1 env) (match-string 2 env)))))))) + (cl-incf (doom-cli-context-step context)) + (with-file-modes #o600 + (doom-log "restart: writing context to %s" context-file) + (doom-file-write + context-file (let ((newcontext (copy-doom-cli-context context)) + (print-level nil) + (print-length nil) + (print-circle nil) + (print-escape-newlines t)) + ;; REVIEW: Use `print-unreadable-function' when 28 support + ;; is dropped. + (letf! (defmacro convert-buffer (fn) + `(setf (,fn newcontext) (with-current-buffer (,fn context) + (buffer-string)))) + (convert-buffer doom-cli-context-stdin) + (convert-buffer doom-cli-context-stdout) + (convert-buffer doom-cli-context-stderr)) + newcontext)) + (doom-log "restart: writing post-script to %s" script-file) + (doom-file-write + script-file + (pcase-exhaustive doom-cli-shell + (`sh `(,(if (featurep :system 'android) + "#!/bin/sh\n" + "#!/usr/bin/env sh\n") + "trap _doomcleanup EXIT\n" + "_doomcleanup() {\n rm -f " ,persistent-files "\n}\n" + "_doomrun() {\n " ,command "\n}\n" + ,(cl-loop for (var . val) in persisted-env + if (<= (length val) 2048) ; Prevent "Argument list too long" errors + concat (format "%s=%s \\\n" var (shell-quote-argument val)) + else do (doom-log 1 "restart: wiscarding envvar %S for being too long (%d)" var (length val))) + ,(format "PATH=\"%s%s$PATH\" \\\n" + (doom-path doom-emacs-dir "bin") + path-separator) + "_doomrun \"$@\"\n")) + (`pwsh `("try {\n" + ,(cl-loop for (var . val) in persisted-env + concat (format " $__%s = $env:%s; $env:%s = %S\n " + var var var val)) + ,command + "\n} finally {\n" + ,(cl-loop for file in persistent-files + concat (format " Remove-Item -Path %S\n " file)) + ,(cl-loop for (var . val) in envvars + concat (format " $env:%s = $__%s\n " var var)) + "\n}"))))) + (doom-log "_doomrun: %s %s" + (cl-loop for (var . val) in persisted-env + concat (format "%s=%s \\\n" var (shell-quote-argument val))) + command) + (doom-log "_doomcleanup: %s" persistent-files) + ;; Error code 254 is special: it indicates to the caller that the + ;; post-script should be executed after this session ends. It's up to + ;; `doom-cli-run's caller to enforce this (see bin/doom's shebang for a + ;; comprehensive example). + (doom-cli--exit 254 context))) + +(defun doom-cli--exit (args context) + "Accepts one of the following: + + (CONTEXT [ARGS...]) + TODO + (STRING [ARGS...]) + TODO + (:restart [ARGS...]) + TODO + (:pager [FILE...]) + TODO + (:pager? [FILE...]) + TODO + (INT) + TODO" + (let ((command (or (car-safe args) args)) + (args (if (car-safe args) (cdr-safe args)))) + (pcase command + ;; If an integer, treat it as an exit code. + ((pred (integerp)) + (setq doom-cli--exit-code command) + (kill-emacs command)) + + ;; Otherwise, run a command verbatim. + ((pred (stringp)) + (doom-cli--restart (format "%s %s" command (combine-and-quote-strings args)) + context)) + + ;; Same with buffers. + ((pred (bufferp)) + (doom-cli--restart (with-current-buffer command (buffer-string)) + context)) + + ;; If a context is given, restart the current session with the new context. + ((pred (doom-cli-context-p)) + (doom-cli--exit-restart args command)) + + ;; Run a custom action, defined in `doom-cli-exit-commands'. + ((pred (keywordp)) + (if-let (fn (alist-get command doom-cli-exit-commands)) + (funcall fn args context) + (error "Invalid exit command: %s" command))) + + ;; Any other value is invalid. + (_ (error "Invalid exit code or command: %s" command))))) + +(defun doom-cli--exit-restart (args context) + "Restart the session, verbatim (persisting CONTEXT). + +ARGS are addiitonal arguments to pass to the sub-process (in addition to the +ones passed to this one). It may contain :omit -- all arguments after this will +be removed from the argument list. They may specify number of arguments in the +format: + + --foo=4 omits --foo plus four following arguments + --foo=1 omits --foo plus one following argument + --foo= equivalent to --foo=1 + --foo=* omits --foo plus all following arguments + +Arguments don't have to be switches either." + (let ((pred (fn! (not (keywordp %)))) + (args (append (doom-cli-context-whole context) + (flatten-list args)))) + (let ((argv (seq-take-while pred args)) + (omit (mapcar (fn! (seq-let (arg n) (split-string % "=") + (cons + arg (cond ((not (stringp n)) 0) + ((string-empty-p n) 1) + ((equal n "*") -1) + ((string-to-number n)))))) + (seq-take-while pred (cdr (memq :omit args))))) + newargs) + (when omit + (while argv + (let ((arg (pop argv))) + (if-let (n (cdr (assoc arg omit))) + (if (= n -1) + (setq argv nil) + (dotimes (i n) (pop argv))) + (push arg newargs))))) + (doom-cli--exit (cons "$1" (or (nreverse newargs) argv)) + context)))) + +(defun doom-cli--exit-pager (args context) + "Invoke pager on output unconditionally. + +ARGS are options passed to less. If DOOMPAGER is set, ARGS are ignored." + (let ((pager (or doom-cli-pager (getenv "DOOMPAGER")))) + (cond ((eq doom-cli-shell 'pwsh) + ;; Pager isn't supported in powershell + (doom-cli--exit 0 context)) + + ((null (or pager (executable-find "less"))) + (user-error "No pager set or available") + (doom-cli--exit 1 context)) + + ((or (doom-cli-context-pipe-p context :out t) + (equal pager "")) + (doom-cli--exit 0 context)) + + ((let ((tmpfile (doom-cli--output-file 'output context)) + (coding-system-for-write 'utf-8)) + (with-file-modes #o700 + (make-directory (file-name-directory tmpfile) t)) + (with-file-modes #o600 + (with-temp-file tmpfile + (insert-buffer-substring (doom-cli-context-stdout context)))) + (doom-cli--restart + (format "%s <%s; rm -f%s %s" + (or pager + (format "less %s" + (combine-and-quote-strings + (append (if doom-print-backend '("-r")) ; process ANSI codes + (or (delq nil args) '("+g")))))) + (shell-quote-argument tmpfile) + (if init-file-debug "v" "") + (shell-quote-argument tmpfile)) + context)))))) + +(defun doom-cli--exit-pager-maybe (args context) + "Invoke pager if stdout is longer than TTY height * `doom-cli-pager-ratio'. + +ARGS are options passed to less. If DOOMPAGER is set, ARGS are ignored." + (doom-cli--exit + (if (eq doom-cli-shell 'pwsh) + 0 + (let ((threshold (ceiling (* (doom-cli-context-height context) + doom-cli-pager-ratio)))) + (if (>= (let ((stdout (doom-cli-context-stdout context))) + (if (fboundp 'buffer-line-statistics) + (car (buffer-line-statistics stdout)) + (with-current-buffer stdout + (count-lines (point-min) (point-max))))) + threshold) + (cons :pager args) + 0))) + context)) + +;; (defun doom-cli--exit-editor (args context)) ; TODO Launch $EDITOR + +;; (defun doom-cli--exit-emacs (args context)) ; TODO Launch Emacs subsession + + + +;; +;;; Migration paths + +;; (defvar doom-cli-context-restore-functions +;; '(doom-cli-context--restore-legacy-fn) +;; "A list of functions intended to unserialize `doom-cli-context'. + +;; They all take one argument, the raw data saved to $__DOOMCONTEXT. Each function +;; must return the version string corresponding to the version of Doom they have +;; transformed it for.") + +;; (defun doom-cli-context-restore (file context) +;; "Restore the last restarted context from FILE into CONTEXT." +;; (when (and (stringp file) +;; (file-exists-p file)) +;; (when-let* ((data (with-temp-buffer +;; (insert-file-contents file) +;; (read (current-buffer)))) +;; (version (if (stringp (car data)) (car data) "0")) +;; (old-context (if (string (car data)) (cdr data) data)) +;; (new-context (make-doom-cli-context)) +;; (struct-info (cl-loop for (slot _initval . plist) in (cdr (cl-struct-slot-info 'doom-cli-context)) +;; collect (cons (cl-struct-slot-offset 'doom-cli-context slot) +;; (cons slot plist))))) + +;; ;; (let ((version (if (stringp (car data)) (car data) "0")) +;; ;; (data (if (string (car data)) (cdr data) data)) +;; ;; (newcontext (make-doom-cli-context))) +;; ;; (dolist (fn doom-cli-context-restore-functions) +;; ;; (setq newcontext (funcall fn newcontext data version)))) + +;; (unless (doom-cli-context-p old-context) +;; (error "An invalid context was restored from file: %s" file)) +;; (unless (equal (doom-cli-context-prefix context) +;; (doom-cli-context-prefix old-context)) +;; (error "Restored context belongs to another script: %s" +;; (doom-cli-context-prefix old-context))) +;; (pcase-dolist (`(,slot ,_ . ,plist) +;; (cdr (cl-struct-slot-info 'doom-cli-context))) +;; (unless (plist-get plist :skip) +;; (let* ((idx (cl-struct-slot-offset 'doom-cli-context slot)) +;; (old-value (aref old-context idx))) +;; (aset context idx +;; (pcase (plist-get plist :type) +;; (`alist +;; (dolist (entry old-value (aref context idx)) +;; (setf (alist-get (car entry) (aref context idx)) (cdr entry)))) +;; (`buffer +;; (with-current-buffer (aref context idx) +;; (insert old-value) +;; (current-buffer))) +;; (_ old-value)))))) +;; (run-hook-with-args 'doom-cli-create-context-functions context) +;; (delete-file file) +;; (doom-log "Restored context: %s" (doom-cli-context-pid context)) +;; context))) + +;; (defun doom-cli-context--restore-legacy-fn (data old-version) +;; "Update `doom-cli-context' from <3.0.0 to 3.0.0." +;; (when (or (equal old-version "3.0.0-dev") +;; (string-match-p "^2\\.0\\." old-version)) + +;; "3.0.0")) + +;; (defun doom-cli-context--restore-3.1.0-fn (data old-version)) + + +;; +;;; Misc + +(defun doom-cli-load (cli) + "If CLI is autoloaded, load it, otherwise return it unchanged." + (or (when-let* ((path (doom-cli-autoload cli)) + (path (locate-file-internal path doom-cli-load-path load-suffixes))) + (doom-log "load: autoload %s" path) + (let ((doom-cli--group-plist (doom-cli-plist cli))) + (doom-load path)) + (let* ((key (doom-cli-key cli)) + (cli (gethash key doom-cli--table))) + (when (doom-cli-autoload cli) + (signal 'doom-cli-autoload-error (list (doom-cli-command cli) path))) + cli)) + cli)) + +(defun doom-cli-load-all () + "Immediately load all autoloaded CLIs." + (dolist (key (hash-table-keys doom-cli--table)) + (doom-cli-load (gethash key doom-cli--table)))) + + +;; +;;; DSL + +(defmacro defcli! (commandspec arglist &rest body) + "Defines a CLI command. + +COMMANDSPEC is the specification for the command that will trigger this CLI. It +can either be a symbol or list of symbols (or nested symbols). Nested lists are +treated as a list of aliases for the command. For example: + + (defcli! doom () ...) ; invoked on 'doom' + (defcli! (doom foo) () ...) ; invoked on 'doom foo' + (defcli! (doom (foo bar)) () ...) ; invoked on 'doom foo' or 'doom bar' + +COMMANDSPEC may be prefixed with any of these special keywords: + + :root ... + This command will ignore any :prefix set by a parent `defcli-group!'. + :before ... + This command will run before the specified command(s). + :after ... + This command will run after the specified command(s). + :version + A special handler, executed when 'X --version' is called. Define your own, + if you don't want it spewing Doom's version information. + :help COMMAND... + A special handler, executed when help documentation is requested for a + command. E.g. 'doom help foo' or 'doom foo --help' will call (:help foo). + You can define your own global :help handler, or one for a specific command. + :dump COMMAND... + A special handler, executed when the __DOOMDUMP environment variable is set. + You can define one for a specific COMMAND, or omit it to redefine the + catch-all :dump handler. + + The default implementation (living in lisp/doom-cli.el) will either: + + a) Dump to stdout a list of `doom-cli' structs for the commands and pseudo + commands that would've been executed had __DOOMDUMP not been set. + b) Or, given only \"-\" as an argument, dump all of `doom-cli--table' to + stdout. This table contains all known `doom-cli's (after loading + autoloaded ones). + +To interpolate values into COMMANDSPEC (e.g. to dynamically generate commands), +use the comma operator: + + (let ((somevar 'bfg)) + (defcli! (doom ,somevar) ...)) + +DOCSTRING is a string description; its first line should be a short summary +(under 60 characters) of what the command does. It will be used in the cramped +command listings served by help commands. The rest of DOCSTRING lines should be +no longer than 80 columns, and should go into greater detail. This documentation +may use `quoting' to appropriately highlight ARGUMENTS, --options, or $ENVVARS. + +DOCSTRING may also contain sections denoted by a capitalized header ending with +a colon and newline, and its contents indented by 2 spaces. These will be +appended to the end of the help documentation for that command. These three +sections are special: + + ARGUMENTS: + Use this to specify longer-form documentation for arguments. They are + prepended to the documentation for commands. If pseudo CLIs specify their + own ARGUMENTS sections, they are joined with that of the root command's CLI + as well. E.g. ':before doom sync's ARGUMENTS will be prepended to 'doom + sync's. + OPTIONS: + Use this to specify longer-form documentation for options. They are appended + to the auto-generated section of the same name. Only the option needs to be + specified for its lookup behavior to work. See bin/doom's `doom' command as + an example. + EXAMPLES: + To list example uses of the containing script. These are appended to + SYNOPSIS in generated manpages, but treated as a normal section otherwise + (i.e. appended to 'doom help's output). + +DOCSTRING may use any of these format specifications: + + %p The running script's prefix. E.g. for 'doom ci deploy-hooks' the + prefix is 'doom'. + %c The parent command minus the prefix. E.g. for 'doom ci deploy-hooks', + the command is 'ci deploy-hooks'. + +ARGLIST is a specification for options and arguments that is accepted by this +command. Arguments are represented by either a symbol or a cons cell where +(SYMBOL . DOCUMENTATION), and option specifications are lists in the following +formats: + + ([TYPE] VAR (FLAGSPEC... [ARGSPEC...]) [DESCRIPTION]) + + TYPE + Optional. One of &flag or &multi (which correspond to &flags and &multiple, + respectively, and are used for specifying a type inline, if desired). + VAR + Is the symbol to bind that option's value to. + FLAGSPEC + A list of switches or sub-lists thereof. Each switch is a string, e.g. + \"--foo\" \"-b\" \"--baz\". + + Nested lists will be treated as logical groups of switches in documentation. + E.g. for + + With (\"--foo\" \"--bar\" [ARGSPEC...]) you get: + + --foo, --bar + [Documentation] + + With ((\"--foo\") (\"--bar\") [ARGSPEC...]) you get: + + --foo + --bar + [Documentation] + + Use this to logically group options that have many, but semantically + distinct switches. + ARGSPEC + A list of arguments or sub-lists thereof. Each argument is either a string + or symbol. + + If a string, they are used verbatim as the argument's documentation. Use + this to document more complex specifications, like \"[user@]host[:port]\". + Use reference `quotes' to highlight arguments appropriately. No input + validation is performed on these arguments. + + If a symbol, this is equivalent to (upcase (format \"`%s'\" SYMBOL)), but + its arguments will also be implicitly validated against + `doom-cli-option-arg-types'. + + A nested list indicates that an argument accepts multiple types, and are + implicitly joined into \"`ARG1'|`ARG2'|...\". Input validation is performed + on symbols only. + + WARNING: If this option is a &flag, the option must not accept arguments. + Instead, use ARGSPEC to specify a single, default value (one of `:yes' or + `:no'). + DESCRIPTION + A one-line description of the option. Use reference `quotes' to + appropriately highlight arguments, options, and envvars. A syntax exists for + adding long-form option documentation from the CLI's docstring. See + DOCSTRING above. + +ARGLIST may be segmented with the following auxiliary keywords: + + &args ARG + The rest of the literal arguments are stored in ARG. + &cli ARG + The called `doom-cli' struct is bound to ARG. + &context ARG + The active `doom-cli-context' struct is bound to ARG. + &flags OPTION... + An option '--foo' declared after &flags will implicitly include a + '--no-foo', and will appear as \"--[no-]foo\" in 'doom help' docs. + &multiple OPTION... + Options specified after &multiple may be passed to the command multiple + times. Its symbol will be bound to a list of cons cells containing (FLAG . + VALUE). + &optional ARG... + Indicates that the (literal) arguments after it are optional. + &input ARG + ARG will be bound to the input piped in from stdin, as a string, or nil if + unavailable. If you want access to the original buffer, use + (doom-cli-context-stdin context) instead. + &rest ARG + All switches and arguments, unprocessed, after this command. If given, any + unrecognized switches will not throw an error. This will also prevent + subcommands beneath this command from being recognized. Use with care! + + Any non-option arguments before &optional, &rest, or &args are required. + +BODY is a list of arbitrary elisp forms that will be executed when this command +is called. BODY may begin with a plist to set metadata about it. The recognized +properties: + + :alias (CMD...) + Designates this command is an alias to CMD, which is a command specification + identical to COMMANDSPEC. + :benchmark BOOL + If non-nil, display a benchmark after the command finishes. + :disable BOOL + If non-nil, the command will not be defined. + :docs STRING + An alternative to DOCSTRING for defining documentation for this command. + :group (STR...) + A breadcrumb of group names to file this command under. They will be + organized by category in the CLI documentation (available through SCRIPT + {--help,-?,help}). + :hide BOOL + If non-nil, don't display this command in the help menu or in {ba,z}sh + completion (though it will still be callable). + :partial BOOL + If non-nil, this command is treated as partial, an intermediary command + intended as a stepping stone toward a non-partial command. E.g. were you to + define (doom foo bar), two \"partial\" commands are implicitly created: + \"doom\" and \"doom foo\". When called directly, partials will list its + subcommands and complain that a subcommand is rqeuired, rather than display + an 'unknown command' error. + :prefix (STR...) + A command path to prepend to the command name. This is more useful as part + of `defcli-group!'s inheritance. + +The BODY of commands with a non-nil :alias, :disable, or :partial will be +ignored. + +\(fn COMMANDSPEC ARGLIST [DOCSTRING] &rest BODY...)" + (declare (indent 2) (doc-string 3)) + (let ((docstring (if (stringp (car body)) (pop body))) + (plist (cl-loop for (key val) on body by #'cddr + while (keywordp key) + collect (pop body) + collect (pop body))) + options arguments bindings) + (let ((type '&required)) + (dolist (arg arglist) + (cond ((listp arg) + (let* ((inline-type (cdr (assq (car arg) doom-cli-option-types))) + (type (or inline-type type)) + (args (if inline-type (cdr arg) arg))) + (push (apply (or (alist-get type doom-cli-option-generators) + (signal 'doom-cli-definition-error + (cons "Invalid option type" type))) + args) + options) + (push (car args) bindings))) + ((memq arg doom-cli-argument-types) + (setq type arg)) + ((string-prefix-p "&" (symbol-name arg)) + (signal 'doom-cli-definition-error (cons "Invalid argument specifier" arg))) + ((push arg bindings) + (push arg (alist-get type arguments)))))) + (dolist (arg arguments) + (setcdr arg (nreverse (cdr arg)))) + `(let (;; Define function early to prevent overcapturing + (fn ,(let ((clisym (make-symbol "cli")) + (alistsym (make-symbol "alist"))) + `(lambda (,clisym ,alistsym) + (let ,(cl-loop for arg in (nreverse bindings) + unless (string-prefix-p "_" (symbol-name arg)) + collect `(,arg (cdr (assq ',arg ,alistsym)))) + ,@body))))) + ;; `cl-destructuring-bind's will validate keywords, so I don't have to + (cl-destructuring-bind + (&whole plist &key + alias autoload _benchmark docs disable hide _group partial + _prefix) + (append (list ,@plist) doom-cli--group-plist) + (unless disable + (let* ((command (doom-cli-command-normalize (backquote ,commandspec) plist)) + (type (if (keywordp (car command)) (pop command))) + (commands (doom-cli--command-expand command t)) + (target (pop commands))) + (dolist (prop '(:autoload :alias :partial :hide)) + (cl-remf plist prop)) + (puthash (delq nil (cons type target)) + (make-doom-cli + :command target + :type type + :docs (doom-cli--parse-docs (or ',docstring docs)) + :arguments ',arguments + :options ',(nreverse options) + :autoload autoload + :alias (if alias (doom-cli-command-normalize alias plist)) + :plist (append plist (list :hide (and (or hide type) t))) + :fn (unless (or partial autoload) fn)) + doom-cli--table) + (let ((docs (doom-cli--parse-docs docs))) + (dolist (alias (cl-loop for c in commands + while (= (length c) (length target)) + collect (pop commands))) + (puthash (delq nil (cons type alias)) + (make-doom-cli + :command alias + :type type + :docs docs + :autoload autoload + :alias (unless autoload (delq nil (cons type target))) + :plist (append plist '(:hide t))) + doom-cli--table)) + (dolist (partial commands) + (let ((cli (gethash partial doom-cli--table))) + (when (or (null cli) (doom-cli-autoload cli)) + (puthash (delq nil (cons type partial)) + (make-doom-cli + :command partial + :type type + :docs docs + :plist (list :group (plist-get plist :group))) + doom-cli--table))))) + target)))))) + +(defmacro defcli-alias! (commandspec target &rest plist) + "Define a CLI alias for TARGET at COMMANDSPEC. + +See `defcli!' for information about COMMANDSPEC. +TARGET is not a command specification, and should be a command list." + `(defcli! ,commandspec () :alias ',target ,@plist)) + +(defmacro defcli-obsolete! (commandspec target when) + "Define an obsolete CLI COMMANDSPEC that refers users to NEW-COMMAND. + +See `defcli!' for information about COMMANDSPEC. +TARGET is simply a command list. +WHEN specifies what version this command was rendered obsolete." + `(let ((ncommand (doom-cli-command-normalize (backquote ,target) doom-cli--group-plist))) + (defcli! ,commandspec (&context _context &cli cli &rest args) + :docs (format "An obsolete alias for '%s'." (doom-cli-command-string ncommand)) + :hide t + (print! (warn "'%s' was deprecated in %s") + (doom-cli-command-string cli) + ,when) + (print! (warn "It will eventually be removed; use '%s' instead.") + (doom-cli-command-string ncommand)) + (call! ',target args)))) + +(defmacro defcli-stub! (commandspec &optional _argspec &rest body) + "Define a stub CLI, which will throw an error if invoked. + +Use this to define commands that will eventually be implemented, but haven't +yet. They won't be included in command listings (by help documentation)." + (declare (indent 2) (doc-string 3)) + `(defcli! ,commandspec (&rest _) + ,(concat "THIS COMMAND IS A STUB AND HAS NOT BEEN IMPLEMENTED YET." + (if (stringp (car body)) (concat "\n\n" (pop body)))) + :hide t + (user-error "Command not implemented yet"))) + +(defmacro defcli-autoload! (commandspec &optional path &rest plist) + "Defer loading of PATHS until PREFIX is called." + `(let* ((doom-cli--group-plist (append (list ,@plist) doom-cli--group-plist)) + (commandspec (doom-cli-command-normalize ',commandspec)) + (commands (doom-cli--command-expand commandspec)) + (path (or ,path + (when-let* ((cmd (car commands)) + (last (car (last cmd))) + (last (if (listp last) (car last) last))) + (format "%s" last)) + (error "Failed to deduce autoload path for: %s" spec))) + (cli (doom-cli-get (car commands) nil t))) + (when (or (null cli) + (doom-cli-autoload cli)) + (defcli! ,commandspec () :autoload path)))) + +(defmacro defcli-group! (&rest body) + "Declare common properties for any CLI commands defined in BODY." + (when (stringp (car body)) + (push :group body)) + `(let ((doom-cli--group-plist (copy-sequence doom-cli--group-plist))) + ,@(let (forms) + (while (keywordp (car body)) + (let ((key (pop body)) + (val (pop body))) + (push `(cl-callf plist-put doom-cli--group-plist + ,key ,(if (eq key :prefix) + `(append (plist-get doom-cli--group-plist ,key) + (ensure-list ,val)) + val)) + forms))) + (nreverse forms)) + ,@body)) + +(defun exit! (&rest args) + "Exits the current CLI session. + +With ARGS, you may specify a shell command or action (see +`doom-cli-exit-commands') to execute after this Emacs process has ended. For +example: + + (exit! \"$@\") or (exit! :restart) + This reruns the current command with the same arguments. + (exit! \"$@ -h -c\") + This reruns the current command with two new switches. + (exit! :restart \"-c\" :omit \"--foo=2\" \"--bar\") + This reruns the current command with one new switch (-c) and two switches + removed (--foo plus two arguments and --bar). + (exit! \"emacs -nw FILE\") + Opens Emacs on FILE + (exit! \"emacs\" \"-nw\" \"FILE\") + Opens Emacs on FILE, but each argument is escaped (and nils are ignored). + (exit! t) or (exit! nil) + A safe way to simply abort back to the shell with exit code 0 + (exit! 42) + Abort to shell with an explicit exit code. + (exit! context) + Restarts the current session, but with context (a `doom-cli-context' struct). + (exit! :pager [FILES...]) + Invoke $DOOMPAGER (or less) on the output of this session. If ARGS are given, launch the pager on those + (exit! :pager? [FILES...]) + Same as :pager, but does so only if output is longer than the terminal is + tall. + +See `doom-cli--restart' for implementation details." + (throw 'exit (flatten-list args))) + +(defun call! (&rest command) + "A convenience wrapper around `doom-cli-call'. + +Implicitly resolves COMMAND relative to the running CLI, and uses the active +context (so you don't have to pass a context)." + (doom-cli-call (doom-cli-command-normalize + (flatten-list command) + `(:prefix + ,(doom-cli-context-prefix doom-cli--context) + ,@(doom-cli-context-command doom-cli--context))) + doom-cli--context)) + +(defun run! (prefix &rest args) + "Parse and execute ARGS. + +This is the entry point for any shell script that rely on Doom's CLI framework. +It should be called once, at top-level, and never again (use `doom-cli-call' for +nested calls instead). + +PREFIX is the name (string) of the top-level shell script (i.e. $0). All +commands that belong to this shell session should use PREFIX as the first +segment in their command paths. + +ARGS is a list of string arguments to execute. + +See bin/doom's shebang for an example of what state needs to be initialized for +Doom's CLI framework. In a nutshell, Doom is expecting the following environment +variables to be set: + + __DOOMGEOM The dimensions of the current terminal (W . H) + __DOOMPIPE Must contain 0 if script is being piped into, 1 if piping it out + __DOOMGPIPE Like __DOOMPIPE, but is the pipe state of the super process + __DOOMPID A unique ID for this session and its exit script processes + __DOOMSTEP How many layers deep this session has gotten + +The script should also execute ${temporary-file-directory}/doom.sh if Emacs +exits with code 254. This script is auto-generated as needed, to simulate exec +syscalls. See `doom-cli--restart' for technical details. + +Once done, this function kills Emacs gracefully and writes output to log files +(stdout to `doom-cli--output-file', stderr to `doom-cli-debug-file', and any +errors to `doom-cli-error-file')." + (when doom-cli--context + (error "Cannot nest `run!' calls")) + (run-hooks 'doom-cli-initialize-hook) + (with-doom-context 'run + (let* ((args (flatten-list args)) + (context (make-doom-cli-context :prefix prefix :whole args)) + (doom-cli--context context) + (write-logs-fn (doom-partial #'doom-cli--output-write-logs-h context)) + (show-benchmark-fn (doom-partial #'doom-cli--output-benchmark-h context))) + ;; Clone output to stdout/stderr buffers for logging. + (doom-cli-redirect-output context + (doom-log "run!: %s %s" prefix (combine-and-quote-strings args)) + (add-hook 'kill-emacs-hook show-benchmark-fn 94) + (add-hook 'kill-emacs-hook write-logs-fn 95) + (when (doom-cli-context-pipe-p context :out t) + (setq doom-print-backend nil)) + (when (doom-cli-context-pipe-p context :in) + (with-current-buffer (doom-cli-context-stdin context) + (while (if-let (in (ignore-errors (read-from-minibuffer ""))) + (insert in "\n") + (ignore-errors (delete-char -1)))))) + (doom-cli--exit + (catch 'exit + (condition-case e + (let* ((args (cons (if (getenv "__DOOMDUMP") :dump prefix) args)) + (context (doom-cli-context-restore (getenv "__DOOMCONTEXT") context)) + (context (doom-cli-context-parse args context))) + (run-hook-with-args 'doom-cli-before-run-functions context) + (let ((result (doom-cli-context-execute context))) + (run-hook-with-args 'doom-cli-after-run-functions context result)) + 0) + (doom-cli-wrong-number-of-arguments-error + (pcase-let ((`(,command ,flag ,args ,min ,max) (cdr e))) + (print! (red "Error: %S expected %s argument%s, but got %d") + (or flag (doom-cli-command-string + (if (keywordp (car command)) + command + (cdr command)))) + (if (or (= min max) + (= max most-positive-fixnum)) + min + (format "%d-%d" min max)) + (if (or (= min 0) (> min 1)) "s" "") + (length args)) + (doom-cli-call `(:help "--synopsis" "--postamble" ,@(cdr (doom-cli--command context))) context e)) + 5) + (doom-cli-unrecognized-option-error + (print! (red "Error: unknown option %s") (cadr e)) + (doom-cli-call `(:help "--synopsis" "--postamble" ,@(cdr (doom-cli--command context))) context e) + 5) + (doom-cli-invalid-option-error + (pcase-let ((`(,types ,option ,value ,errors) (cdr e))) + (print! (red "Error: %s received invalid value %S") + (string-join (doom-cli-option-switches option) "/") + value) + (print! (bold "\nValidation errors:")) + (dolist (err errors) (print! (item "%s." (fill err))))) + (doom-cli-call `(:help "--postamble" ,@(cdr (doom-cli--command context))) context e) + 5) + (doom-cli-command-not-found-error + (let* ((command (cdr e)) + (cli (doom-cli-get command))) + (cond ((null cli) + (print! (red "Error: unrecognized command '%s'") + (doom-cli-command-string (or (cdr command) command))) + (doom-cli-call `(:help "--similar" "--postamble" ,@(cdr command)) context e)) + ((null (doom-cli-fn cli)) + (print! (red "Error: a subcommand is required")) + (doom-cli-call `(:help "--subcommands" "--postamble" ,@(cdr command)) context e)))) + 4) + (doom-cli-invalid-prefix-error + (let ((prefix (cadr e))) + (print! (red "Error: `run!' called with invalid prefix %S") prefix) + (if-let (suggested (cl-loop for cli being the hash-value of doom-cli--table + unless (doom-cli-type cli) + return (car (doom-cli-command cli)))) + (print! "Did you mean %S?" suggested) + (print! "There are no commands defined under %S." prefix))) + 4) + (user-error + (print! (red "Error: %s") (cadr e)) + (print! "\nAborting...") + 3))) + context))))) + +(defalias 'sh! #'doom-call-process) + +(defalias 'sh!! #'doom-exec-process) + +;; TODO Make `git!' into a more sophisticated wrapper around git +(defalias 'git! (doom-partial #'straight--process-run "git")) + +(defun get! (key) (doom-cli-context-get doom-cli--context key)) + +(defun put! (key val) (doom-cli-context-put doom-cli--context key val)) + + +;; +;;; doom-cli-help +;; +;; 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: +;; +;; (defcli-alias! (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-help (cli) + "Return an alist of documentation summarizing CLI (a `doom-cli')." + (let* ((rcli (doom-cli-get cli)) + (docs (doom-cli-docs rcli))) + `((command . ,(doom-cli-command-string cli)) + (summary . ,(or (cdr (assoc "SUMMARY" docs)) "[TODO]")) + (description . ,(or (cdr (assoc "MAIN" docs)) "")) + (synopsis . ,(doom-cli-help--synopsis cli)) + (arguments . ,(doom-cli-help--arguments rcli)) + (options . ,(doom-cli-help--options rcli)) + (commands . ,(doom-cli-subcommands cli 1)) + (sections . ,(seq-filter #'cdr (cddr docs)))))) + +(defun doom-cli-help-similar-commands (command &optional maxscore) + "Return N commands that are similar to COMMAND." + (seq-take-while + (fn! (>= (car %) (or maxscore 0.0))) + (seq-sort-by + #'car #'> + (cl-loop with prefix = (seq-find #'doom-cli-get (nreverse (doom-cli--command-expand command t))) + with input = (doom-cli-command-string (cdr (doom-cli--command command t))) + for command in (hash-table-keys doom-cli--table) + if (doom-cli-fn (doom-cli-get command)) + if (equal prefix (seq-take command (length prefix))) + collect (cons (doom-cli-help--similarity + input (doom-cli-command-string (cdr command))) + command))))) + +(defun doom-cli-help--similarity (a b) + (- 1 (/ (float (doom-cli-help--string-distance a b)) + (max (length a) (length b))))) + +(defun doom-cli-help--string-distance (a b) + "Calculate the Restricted Damerau-Levenshtein distance between A and B. +This is also known as the Optimal String Alignment algorithm. + +It is assumed that A and B are both strings, and before processing both are +converted to lowercase. + +This returns the minimum number of edits required to transform A +to B, where each edit is a deletion, insertion, substitution, or +transposition of a character, with the restriction that no +substring is edited more than once." + (let ((a (downcase a)) + (b (downcase b)) + (alen (length a)) + (blen (length b)) + (start 0)) + (when (> alen blen) + (let ((c a) + (clen alen)) + (setq a b alen blen + b c blen clen))) + (while (and (< start (min alen blen)) + (= (aref a start) (aref b start))) + (cl-incf start)) + (cl-decf start) + (if (= (1+ start) alen) + (- blen start) + (let ((v0 (make-vector (- blen start) 0)) + (v1 (make-vector (- blen start) 0)) + (a_i (aref a (max 0 start))) + (current 0) + a_i-1 b_j b_j-1 + left transition-next + above this-transition) + (dotimes (vi (length v0)) + (aset v0 vi (1+ vi))) + (dolist (i (number-sequence (1+ start) (1- alen))) + (setq a_i-1 a_i + a_i (aref a i) + b_j (aref b (max 0 start)) + left (- i start 1) + current (- i start) + transition-next 0) + (dolist (j (number-sequence (1+ start) (1- blen))) + (setq b_j-1 b_j + b_j (aref b j) + above current + current left + this-transition transition-next + transition-next (aref v1 (- j start))) + (aset v1 (- j start) current) + (setq left (aref v0 (- j start))) + (unless (= a_i b_j) + ;; Minimum between substitution, deletion, and insertion + (setq current (min (1+ current) (1+ above) (1+ left))) + (when (and (> i (1+ start)) (> j (1+ start)) (= a_i b_j-1) (= a_i-1 b_j)) + (setq current (min current (cl-incf this-transition))))) + (aset v0 (- j start) current))) + current)))) + +;;; 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 .command " - " .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)) noglobal?) + `(,(assq 'local .options)) + .options) + cli)))) + (command (doom-cli-command cli))) + (letf! (defun printsection (section) + (print! "%s\n" + (if (null section) + (dark "TODO") + (markup + (format-spec + section `((?p . ,(car command)) + (?c . ,(doom-cli-command-string (cdr command)))) + 'ignore))))) + (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* ((rcli (doom-cli-get cli)) + (opts (doom-cli-help--options rcli)) + (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 rcli)) + (subcommands? (doom-cli-subcommands rcli 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))))))) + +(defun doom-cli-help--render-synopsis (synopsis &optional prefix) + (let-alist synopsis + (let ((doom-print-indent 0) + (prefix (or prefix "")) + (command (doom-cli-command-string .command))) + (string-trim-right + (format! "%s\n\n" + (fill (concat (bold prefix) + (format "%s " command) + (markup + (join (append .options + (and .options + (or .required + .optional + .rest) + (list (dark "[--]"))) + .required + .optional + .rest)))) + 80 (1+ (length (concat prefix command))))))))) + +;;; 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))) + (nreverse commands))) + (toplevel (assq nil commands)) + (rest (remove toplevel commands)) + (drop (if prefix (length prefix) 0)) + (minwidth + (apply + #'max (or (cl-loop for cmd in (apply #'append (mapcar #'cdr commands)) + for cmd = (seq-drop cmd drop) + collect (length (doom-cli-command-string cmd))) + (list 15)))) + (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 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")))))))))) ;; ;;; Predefined CLIs (:help, :version, and :dump) diff --git a/lisp/doom-elpaca.el b/lisp/doom-elpaca.el new file mode 100644 index 000000000..6af51e0ae --- /dev/null +++ b/lisp/doom-elpaca.el @@ -0,0 +1,12 @@ +;;; lisp/doom-elpaca.el -*- lexical-binding: t; -*- +;;; Commentary: +;; +;; In the near future, Doom will replace Straight with Elpaca. Its configuration +;; will live here. +;; +;;; Code: + +;; TODO + +(provide 'doom-elpaca) +;;; doom-elpaca.el ends here. diff --git a/lisp/doom-lib.el b/lisp/doom-lib.el index 8644884b3..58853495e 100644 --- a/lisp/doom-lib.el +++ b/lisp/doom-lib.el @@ -182,7 +182,8 @@ at the values with which this function was called." (defun doom-load (path &optional noerror) "Load PATH and handle any Doom errors that arise from it. -If NOERROR, don't throw an error if PATH doesn't exist." +If NOERROR, don't throw an error if PATH doesn't exist. +Return non-nil if loading the file succeeds." (doom-log "load: %s %s" (abbreviate-file-name path) noerror) (condition-case-unless-debug e (load path noerror 'nomessage) @@ -283,7 +284,7 @@ TRIGGER-HOOK is a list of quoted hooks and/or sharp-quoted functions." fn (lambda (&rest _) ;; Only trigger this after Emacs has initialized. (when (and (not running?) - (not (doom-context-p 'init)) + (not (doom-context-p 'startup)) (or (daemonp) ;; In some cases, hooks may be lexically unset to ;; inhibit them during expensive batch operations on @@ -412,23 +413,35 @@ The def* forms accepted are: (setq type (list 'symbol-function type))) (list 'cl-letf (list (cons type rest)) body))))))) + +(defmacro quiet!! (&rest forms) + "Run FORMS without generating any output (for real). + +Unlike `quiet!', which will only suppress output in the echo area in interactive +sessions, this truly suppress all output from FORMS." + (declare (indent 0)) + `(if init-file-debug + (progn ,@forms) + (letf! ((standard-output (lambda (&rest _))) + (defun message (&rest _)) + (defun load (file &optional noerror nomessage nosuffix must-suffix) + (funcall load file noerror t nosuffix must-suffix)) + (defun write-region (start end filename &optional append visit lockname mustbenew) + (unless visit (setq visit 'no-message)) + (funcall write-region start end filename append visit lockname mustbenew))) + ,@forms))) + (defmacro quiet! (&rest forms) "Run FORMS without generating any output. This silences calls to `message', `load', `write-region' and anything that writes to `standard-output'. In interactive sessions this inhibits output to the echo-area, but not to *Messages*." + (declare (indent 0)) `(if init-file-debug (progn ,@forms) ,(if noninteractive - `(letf! ((standard-output (lambda (&rest _))) - (defun message (&rest _)) - (defun load (file &optional noerror nomessage nosuffix must-suffix) - (funcall load file noerror t nosuffix must-suffix)) - (defun write-region (start end filename &optional append visit lockname mustbenew) - (unless visit (setq visit 'no-message)) - (funcall write-region start end filename append visit lockname mustbenew))) - ,@forms) + `(quiet!! ,@forms) `(let ((inhibit-message t) (save-silently t)) (prog1 ,@forms (message "")))))) @@ -1059,5 +1072,677 @@ and return the value found in PLACE instead." (defbackport! defalias 'bol #'line-beginning-position) (defbackport! defalias 'eol #'line-end-position) + +;;; Types + +(cl-defstruct doom-module + "TODO" + (index 0 :read-only t) + ;; source + group + name + depth + flags + features + ;; sources + path + ;; disabled-p + ;; frozen-p + ;; layer-p + ;; recipe + ;; alist + ;; package + ;; if + ) + +(cl-defstruct doom-module-context + "Hot cache object for the containing Doom module." + index key path flags features) + + +;;; `doom-context' + +(defvar doom-context '(t) + "A list of symbols identifying all active Doom execution contexts. + +This should never be directly changed, only let-bound, and should never be +empty. Each context describes what phase Doom is in, and may respond to. + +Use `with-doom-context' instead of let-binding or setting this variable +directly. + +All valid contexts: + cli -- executing a Doom CLI or doomscript + emacs -- in an interactive doom session + module -- loading any modules' elisp files + + Universal sub-contexts: + compile -- byte-compiling elisp + startup -- while doom is starting up, before any user config + error -- while Doom is in an error state + + `emacs' sub-contexts: + docs -- while rendering docs in `doom-docs-mode' + reload -- while reloading doom with `doom/reload' + sandbox -- this session was launched from Doom's sandbox + eval -- while interactively evaluating elisp + + `module' sub-contexts: + external -- loading packages or modules outside of $EMACSDIR or $DOOMDIR + config -- loading a module's config.el or cli.el + doctor -- loading a module's doctor.el + init -- loading a module's init.el + package -- loading a module's packages.el or managing packages + source -- while initializing a module source + test -- preparing for or running Doom's unit tests + + `cli' sub-contexts: + run -- running a CLI command") +(put 'doom-context 'valid + '(compile error startup emacs docs reload sandbox eval module external + config doctor init package test cli run)) +(put 'doom-context 'risky-local-variable t) + +(defun doom-context-p (contexts) + "Return t if all CONTEXTS are active, nil otherwise. + +See `doom-context' for possible values for CONTEXT." + (declare (side-effect-free t)) + (catch 'result + (let (result) + (dolist (context (ensure-list contexts) result) + (if (memq context doom-context) + (push context result) + (throw 'result nil)))))) + +(defun doom-context-valid-p (context) + "Return non-nil if CONTEXT is a valid `doom-context'." + (declare (pure t) (side-effect-free error-free)) + (memq context (get 'doom-context 'valid))) + +(defun doom-context-push (contexts) + "Add CONTEXTS to `doom-context', if not present. + +Return list of successfully added contexts. Throws a `doom-context-error' if +CONTEXTS contains invalid contexts." + (let ((contexts (ensure-list contexts))) + (if (cl-loop for context in contexts + unless (doom-context-valid-p context) + return t) + (doom-context-error + (cl-remove-if #'doom-context-valid-p contexts) + "Unrecognized context") + (let (added) + (dolist (context contexts) + (unless (memq context doom-context) + (push context added))) + (when added + (setq doom-context (nconc added doom-context)) + (doom-log 3 ":context: +%s %s" added doom-context) + added))))) + +(defun doom-context-pop (contexts) + "Remove CONTEXTS from `doom-context'. + +Return list of removed contexts if successful. Throws `doom-context-error' if +one of CONTEXTS isn't active." + (if (not (doom-context-p contexts)) + (doom-context-error + doom-context "Attempt to pop missing context" + contexts) + (let ((current-context (copy-sequence doom-context)) + removed) + (dolist (context (ensure-list contexts)) + (setq current-context (delq context current-context)) + (push context removed)) + (when removed + (setq doom-context current-context) + (doom-log 3 ":context: +%s %s" removed doom-context) + removed)))) + +(defmacro with-doom-context (contexts &rest body) + "Evaluate BODY with CONTEXTS added to `doom-context'." + (declare (indent 1)) + `(let ((doom-context doom-context)) + (doom-context-push ,contexts) + ,@body)) + + +;;; `doom-module-context' + +(defvar doom-module-context (make-doom-module-context) + "A `doom-module-context' for the module associated with the current file. + +Never set this variable directly, use `with-doom-module'.") + +(defmacro with-doom-module (key &rest body) + "Evaluate BODY with `doom-module-context' informed by KEY." + (declare (indent 1)) + `(let ((doom-module-context (doom-module-context ,key))) + (doom-log ":context:module: =%s" doom-module-context) + ,@body)) + +(defun doom-module-context (key) + "Return a `doom-module-context' from KEY. + +KEY can be a `doom-module-context', `doom-module', or a `doom-module-key' cons +cell." + (declare (side-effect-free t)) + (or (pcase (type-of key) + (`doom-module-context key) + (`doom-module (ignore-errors (doom-module->context key))) + (`cons (doom-module (car key) (cdr key)))) + (make-doom-module-context :key (doom-module-key key)))) + +(defun doom-module<-context (context) + "Return a `doom-module' plist from CONTEXT." + (declare (side-effect-free t)) + (doom-module-get (doom-module-context-key context))) + +(defun doom-module->context (key) + "Change a `doom-module' into a `doom-module-context'." + (declare (side-effect-free t)) + (pcase-let + (((doom-module index path flags group name) + (if (doom-module-p key) + key (doom-module-get (doom-module-key key))))) + (make-doom-module-context + :index index + :key (cons group name) + :path path + :flags flags))) + +(defun doom-module (group name &optional property) + "Return the `doom-module-context' for any active module by GROUP NAME. + +Return its PROPERTY, if specified." + (declare (side-effect-free t)) + (when-let ((context (get group name))) + (if property + (aref + context + (or (plist-get + (eval-when-compile + (cl-loop with i = 1 + for info in (cdr (cl-struct-slot-info 'doom-module-context)) + nconc (list (doom-keyword-intern (symbol-name (car info))) + (prog1 i (cl-incf i))))) + property) + (error "Unknown doom-module-context property: %s" property))) + context))) + + +;;; `doom-module' + +(defun doom-module-key (key) + "Normalize KEY into a (GROUP . MODULE) tuple representing a Doom module key." + (declare (pure t) (side-effect-free t)) + (cond ((doom-module-p key) + (cons (doom-module-group key) (doom-module-name key))) + ((doom-module-context-p key) + (doom-module-context-key key)) + ((car-safe key) + (if (nlistp (cdr-safe key)) + key + (cons (car key) (cadr key)))) + ((error "Invalid key: %S" key)))) + +(defun doom-module--has-flag-p (flags wanted-flags) + "Return t if the list of WANTED-FLAGS satisfies the list of FLAGS." + (declare (pure t) (side-effect-free error-free)) + (cl-loop with flags = (ensure-list flags) + for flag in (ensure-list wanted-flags) + for flagstr = (symbol-name flag) + if (if (eq ?- (aref flagstr 0)) + (memq (intern (concat "+" (substring flagstr 1))) + flags) + (not (memq flag flags))) + return nil + finally return t)) + +(defun doom-module--fold-flags (flags) + "Returns a collapsed list of FLAGS (a list of +/- prefixed symbols). + +FLAGS is read in sequence, cancelling out negated flags and removing +duplicates." + (declare (pure t) (side-effect-free error-free)) + (let (newflags) + (while flags + (let* ((flag (car flags)) + (flagstr (symbol-name flag))) + (when-let ((sym (intern-soft + (concat (if (eq ?- (aref flagstr 0)) "+" "-") + (substring flagstr 1))))) + (setq newflags (delq sym newflags))) + (cl-pushnew flag newflags :test 'eq)) + (setq flags (cdr flags))) + (nreverse newflags))) + +(defun doom-module-get (key &optional property) + "Returns the plist for GROUP MODULE. Gets PROPERTY, specifically, if set." + (declare (side-effect-free t)) + (when-let ((m (gethash key doom-modules))) + (if property + (aref + m (or (plist-get + (eval-when-compile + (cl-loop with i = 1 + for info in (cdr (cl-struct-slot-info 'doom-module)) + nconc (list (doom-keyword-intern (symbol-name (car info))) + (prog1 i (cl-incf i))))) + property) + (error "Unknown doom-module property: %s" property))) + m))) + +(defun doom-module-active-p (group module &optional flags) + "Return t if GROUP MODULE is active, and with FLAGS (if given)." + (declare (side-effect-free t)) + (when-let ((val (doom-module-get (cons group module) (if flags :flags)))) + (or (null flags) + (doom-module--has-flag-p flags val)))) + +(defun doom-module-exists-p (group module) + "Returns t if GROUP MODULE is present in any active source." + (declare (side-effect-free t)) + (if (doom-module-get group module) t)) + +(cl-defun doom-module--depth< (keya keyb &optional initorder?) + "Return t if module with KEY-A comes before another with KEY-B. + +If INITORDER? is non-nil, grab the car of the module's :depth, rather than it's +cdr. See `doom-module-put' for details about the :depth property." + (declare (pure t) (side-effect-free t)) + (let* ((adepth (doom-module-get keya :depth)) + (bdepth (doom-module-get keyb :depth)) + (adepth (if initorder? (car adepth) (cdr adepth))) + (bdepth (if initorder? (car bdepth) (cdr bdepth)))) + (if (or (null adepth) (null bdepth) + (= adepth bdepth)) + (< (or (doom-module-get keya :index) 0) + (or (doom-module-get keyb :index) 0)) + (< adepth bdepth)))) + +(defun doom-module-list (&optional paths-or-all initorder?) + "Return a list of (:group . name) module keys in order of their :depth. + +PATHS-OR-ALL can either be a non-nil value or a list of directories. If given a +list of directories, return a list of module keys for all modules present +underneath it. If non-nil, return the same, but search `doom-module-load-path' +(includes :doom and :user). Modules that are enabled are sorted first by their +:depth, followed by disabled modules in lexicographical order (unless a :depth +is specified in their .doommodule). + +If INITORDER? is non-nil, sort modules by the CAR of that module's :depth." + (sort (if paths-or-all + (delete-dups + (append (seq-remove #'cdr (doom-module-list nil initorder?)) + (doom-files-in (if (listp paths-or-all) + paths-or-all + doom-module-load-path) + :map #'doom-module-from-path + :type 'dirs + :mindepth 1 + :depth 1))) + (hash-table-keys doom-modules)) + (doom-rpartial #'doom-module--depth< initorder?))) + +(defun doom-module-expand-path (key &optional file) + "Expands a path to FILE relative to KEY, a cons cell: (GROUP . NAME) + +GROUP is a keyword. MODULE is a symbol. FILE is an optional string path. +If the group isn't enabled this returns nil. For finding disabled modules use +`doom-module-locate-path' instead." + (when-let ((path (doom-module-get key :path))) + (if file + (file-name-concat path file) + path))) + +(defun doom-module-locate-path (key &optional file) + "Searches `doom-module-load-path' to find the path to a module by KEY. + +KEY is a cons cell (GROUP . NAME), where GROUP is a keyword (e.g. :lang) and +NAME is a symbol (e.g. \\='python). FILE is a string that will be appended to +the resulting path. If said path doesn't exist, this returns nil, otherwise an +absolute path." + (let (file-name-handler-alist) + (if-let ((path (doom-module-expand-path key file))) + (if (or (null file) + (file-exists-p path)) + path) + (cl-destructuring-bind (group . module) (doom-module-key key) + (let* ((group (doom-keyword-name group)) + (module (if module (symbol-name module))) + (path (file-name-concat group module file))) + (if file + ;; PERF: locate-file-internal is a little faster for finding files, + ;; but its interface for finding directories is clumsy. + (locate-file-internal path doom-module-load-path '("" ".elc" ".el")) + (cl-loop for default-directory in doom-module-load-path + if (file-exists-p path) + return (expand-file-name path)))))))) + +(defun doom-module-locate-paths (module-list file) + "Return all existing paths to FILE under each module in MODULE-LIST. + +MODULE-LIST is a list of cons cells (GROUP . NAME). See `doom-module-list' for +an example." + (cl-loop for key in (or module-list (doom-module-list)) + if (doom-module-locate-path key file) + collect it)) + +(defun doom-module-from-path (path &optional enabled-only?) + "Returns a cons cell (GROUP . NAME) derived from PATH (a file path). +If ENABLED-ONLY?, return nil if the containing module isn't enabled." + (let* ((file-name-handler-alist nil) + (path (expand-file-name path))) + (save-match-data + (cond ((string-match "/modules/\\([^/]+\\)/\\([^/]+\\)\\(?:/.*\\)?$" path) + (when-let* ((group (doom-keyword-intern (match-string 1 path))) + (name (intern (match-string 2 path)))) + (and (or (null enabled-only?) + (doom-module-active-p group name)) + (cons group name)))) + ((file-in-directory-p path doom-core-dir) + (cons :doom nil)) + ((file-in-directory-p path doom-user-dir) + (cons :user nil)))))) + +(defun doom-module-load-path (&optional module-load-path) + "Return a list of file paths to activated modules. + +The list is in no particular order and its file paths are absolute. If +MODULE-DIRS is non-nil, include all modules (even disabled ones) available in +those directories." + (declare (pure t) (side-effect-free t)) + (mapcar #'doom-module-locate-path + (doom-module-list (or module-load-path doom-module-load-path)))) + +(put :if 'lisp-indent-function 2) +(put :when 'lisp-indent-function 'defun) +(put :unless 'lisp-indent-function 'defun) + +(defmacro doom! (&rest modules) + "Bootstraps DOOM Emacs and its modules. + +If the first item in MODULES doesn't satisfy `keywordp', MODULES is evaluated, +otherwise, MODULES is a variadic-property list (a plist whose key may be +followed by one or more values). + +This macro does nothing in interactive sessions, but in noninteractive session +iterates through MODULES, enabling and initializing them. The order of modules +in these blocks dictates their load order (unless given an explicit :depth)." + `(when noninteractive + ;; REVIEW: A temporary fix for flycheck until I complete backporting + ;; module/profile architecture from v3.0. + (when (fboundp 'doom-module-mplist-map) + (doom-module-mplist-map + #'doom-module--put + ,@(if (keywordp (car modules)) + (list (list 'quote modules)) + modules))) + t)) + +;; DEPRECATED Remove in 3.0 +(define-obsolete-function-alias 'featurep! 'modulep! "3.0.0") + +(defmacro modulep! (group &optional module &rest flags) + "Return t if :GROUP MODULE (and +FLAGS) are enabled. + +If FLAGS is provided, returns t if GROUP MODULE has all of FLAGS enabled. + + (modulep! :config default +flag) + (modulep! :config default +flag1 +flag2 +flag3) + +GROUP and MODULE may be omitted when this macro is used from a Doom module's +source (except your $DOOMDIR, which is a special module). Like so: + + (modulep! +flag3 +flag1 +flag2) + (modulep! +flag) + +FLAGS can be negated. E.g. This will return non-nil if ':tools lsp' is enabled +without `+eglot': + + (modulep! :tools lsp -eglot) + +To interpolate dynamic values, use comma: + + (let ((flag '-eglot)) + (modulep! :tools lsp ,flag)) + +For more about modules and flags, see `doom!'." + (if (keywordp group) + (if flags + `(doom-module--has-flag-p + (doom-module (backquote ,group) (backquote ,module) :flags) + (backquote ,flags)) + `(and (get (backquote ,group) (backquote ,module)) t)) + (let ((flags (delq nil (cons group (cons module flags))))) + (if (doom-module-context-index doom-module-context) + `(doom-module--has-flag-p + ',(doom-module-context-flags doom-module-context) + (backquote ,flags)) + `(let ((file (file!))) + (if-let ((module (doom-module-from-path file))) + (doom-module--has-flag-p + (doom-module (car module) (cdr module) :flags) + (backquote ,flags)) + (error "(modulep! %s) couldn't resolve current module from %s" + (backquote ,flags) (abbreviate-file-name file)))))))) + + +;;; `doom-package' + +(cl-defmacro package! + (name &rest plist &key built-in recipe ignore _type _pin _disable) + "Declares a package and how to install it (if applicable). + +This macro is declarative and does not load nor install packages. It is used to +populate `doom-packages' with metadata about the packages Doom needs to keep +track of. + +Only use this macro in a module's packages.el file. + +Accepts the following properties: + + :type core|local|built-in|virtual + Specifies what kind of package this is. Can be a symbol or a list thereof. + `core' = this is a protected package and cannot be disabled! + `local' = this package is being modified in-place. This package's repo is + unshallowed and will be skipped when you update packages. + `built-in' = this package is already built-in (otherwise, will be + installed) + `virtual' = this package is not tracked by Doom's package manager. It won't + be installed or uninstalled. Use this to pin 2nd order dependencies. + :recipe RECIPE + Specifies a straight.el recipe to allow you to acquire packages from external + sources. See https://github.com/radian-software/straight.el#the-recipe-format + for details on this recipe. + :disable BOOL + Do not install or update this package AND disable all of its `use-package!' + and `after!' blocks. + :ignore FORM + Do not install this package. + :pin STR|nil + Pin this package to commit hash STR. Setting this to nil will unpin this + package if previously pinned. + :built-in BOOL|'prefer + Same as :ignore if the package is a built-in Emacs package. This is more to + inform help commands like `doom/help-packages' that this is a built-in + package. If set to 'prefer, the package will not be installed if it is + already provided by Emacs. + +Returns t if package is successfully registered, and nil if it was disabled +elsewhere." + (declare (indent defun)) + (when (and recipe (keywordp (car-safe recipe))) + (cl-callf plist-put plist :recipe `(quote ,recipe))) + ;; :built-in t is basically an alias for :ignore (locate-library NAME) + (when built-in + (when (and (not ignore) + (equal built-in '(quote prefer))) + (setq built-in `(locate-library ,(symbol-name name) nil (get 'load-path 'initial-value)))) + (cl-callf map-delete plist :built-in) + (cl-callf plist-put plist :ignore built-in)) + `(let* ((name ',name) + (plist (cdr (assq name doom-packages))) + (dir (dir!)) + (module (doom-module-from-path dir))) + (unless (doom-context-p 'package) + (signal 'doom-module-error + (list module "package! can only be used in packages.el files"))) + ;; Record what module this declaration was found in + (let ((module-list (plist-get plist :modules))) + (unless (member module module-list) + (cl-callf plist-put plist :modules + (append module-list + (list module) + (when (file-in-directory-p dir doom-user-dir) + '((:user . modules))) + nil)))) + ;; Merge given plist with pre-existing one + (cl-loop for (key value) on (list ,@plist) by 'cddr + when (or (eq key :pin) value) + do (cl-callf plist-put plist key value)) + ;; Some basic key validation; throws an error on invalid properties + (condition-case e + (when-let (recipe (plist-get plist :recipe)) + (cl-destructuring-bind + (&key local-repo _files _flavor _build _pre-build _post-build + _includes _type _repo _host _branch _protocol _remote + _nonrecursive _fork _depth _source _inherit) + recipe + ;; Expand :local-repo from current directory + (when local-repo + (cl-callf plist-put plist :recipe + (plist-put recipe :local-repo + (let ((local-path (expand-file-name local-repo dir))) + (if (file-directory-p local-path) + local-path + local-repo))))))) + (error + (signal 'doom-package-error + (cons ,(symbol-name name) + (error-message-string e))))) + ;; These are the only side-effects of this macro! + (setf (alist-get name doom-packages) plist) + (if (plist-get plist :disable) + (add-to-list 'doom-disabled-packages name) + (with-no-warnings + (cons name plist))))) + +;; DEPRECATED: Will be replaced with new `packages!' macro in v3.0 +(defmacro disable-packages! (&rest packages) + "A convenience macro for disabling packages in bulk. +Only use this macro in a module's (or your private) packages.el file." + (macroexp-progn + (mapcar (lambda (p) `(package! ,p :disable t)) + packages))) + +;; DEPRECATED: Will be replaced with new `packages!' macro in v3.0 +(defmacro unpin! (&rest targets) + "Unpin packages in TARGETS. + +This unpins packages, so that `doom upgrade' or `doom sync -u' will update them +to the latest commit available. Some examples: + +- To disable pinning wholesale: (unpin! t) +- To unpin individual packages: (unpin! packageA packageB ...) +- To unpin all packages in a group of modules: (unpin! :lang :tools ...) +- To unpin packages in individual modules: + (unpin! (:lang python javascript) (:tools docker)) + +Or any combination of the above. + +This macro should only be used from the user's private packages.el. No module +should use it!" + (if (memq t targets) + `(mapc (doom-rpartial #'doom-package-set :unpin t) + (mapcar #'car doom-packages)) + (macroexp-progn + (mapcar + (lambda (target) + (when target + `(doom-package-set ',target :unpin t))) + (cl-loop for target in targets + if (or (keywordp target) (listp target)) + append + (cl-loop with (category . modules) = (ensure-list target) + for (name . plist) in doom-packages + for pkg-modules = (plist-get plist :modules) + if (and (assq category pkg-modules) + (or (null modules) + (cl-loop for module in modules + if (member (cons category module) pkg-modules) + return t)) + name) + collect it) + else if (symbolp target) + collect target))))) + + +;;; `doom-profile' + +(defun doom-profile-key (profile &optional default?) + "Normalize PROFILE into a (NAME . REF) doom-profile key. + +PROFILE can be a `doom-profile', a profile id (i.e. a string in the NAME@REF +format), or a (NAME . REF) cons cell. + +If DEFAULT? is non-nil, an unspecified CAR/CDR will fall bakc to (_default . +0)." + (declare (pure t) (side-effect-free t)) + (let ((default-name (if default? "_default")) + (default-ref (if default? "0"))) + (cond ((eq profile t) (cons default-name default-ref)) + ;; ((doom-profile-p profile) + ;; (cons (or (doom-profile-name profile) default-name) + ;; (or (doom-profile-ref profile) default-ref))) + ((stringp profile) + (save-match-data + (let (case-fold-search) + (if (string-match "^\\([^@]+\\)@\\(.+\\)$" profile) + (cons (match-string 1 profile) + (match-string 2 profile)) + (cons profile default-ref))))) + ((and (consp profile) (nlistp (cdr profile))) + (cons (or (car profile) default-name) + (or (cdr profile) default-ref))) + ((and (null profile) default?) + (cons default-name default-ref)) + ((signal 'wrong-type-argument + (list "Expected PROFILE to be a string, cons cell, or `doom-profile'" + (type-of profile) profile)))))) + +(defun doom-profile-init-file (profile &optional el?) + "Return the init file for PROFILE." + (declare (side-effect-free t)) + (cl-destructuring-bind (name . ref) + (if profile + (doom-profile-key profile t) + (cons nil nil)) + (file-name-concat doom-data-dir name "@" ref + (format "init.%d.%d.%s" + emacs-major-version + emacs-minor-version + (if el? "el" "elc"))))) + +(defun doom-profile-get (profile-name &optional property null-value) + "Return PROFILE-NAME's PROFILE, otherwise its PROPERTY, otherwise NULL-VALUE." + (when (stringp profile-name) + (setq profile-name (intern profile-name))) + (if-let (profile (assq profile-name (doom-profiles))) + (if property + (if-let (propval (assq property (cdr profile))) + (cdr propval) + null-value) + profile) + null-value)) + +(defun doom-profile->id (profile) + "Return a NAME@VERSION id string from profile cons cell (NAME . VERSION)." + (cl-check-type profile cons) + (cl-destructuring-bind (name . ref) (doom-profile-key profile) + (format "%s@%s" name ref))) + (provide 'doom-lib) ;;; doom-lib.el ends here diff --git a/lisp/doom-modules.el b/lisp/doom-modules.el deleted file mode 100644 index 7efc8f689..000000000 --- a/lisp/doom-modules.el +++ /dev/null @@ -1,608 +0,0 @@ -;;; doom-modules.el --- module & package management system -*- lexical-binding: t; -*- -;;; Commentary: -;;; Code: - -;; -;;; Variables - -(defvar doom-modules nil - "A table of enabled modules and metadata. See `doom-modules-initialize'.") - -(define-obsolete-variable-alias 'doom-modules-dirs 'doom-module-load-path "3.0.0") -(defvar doom-module-load-path - (list (file-name-concat doom-user-dir "modules") - (file-name-concat doom-emacs-dir "modules")) - "A list of paths where Doom should search for modules. - -Order determines priority (from highest to lowest). - -Each entry is a string; an absolute path to the root directory of a module tree. -In other words, they should contain a two-level nested directory structure, -where the module's group and name was deduced from the first and second level of -directories. For example: if $DOOMDIR/modules/ is an entry, a -$DOOMDIR/modules/lang/ruby/ directory represents a ':lang ruby' module.") - -;;; Module file variables -(defvar doom-module-init-file "init.el" - "The filename for module early initialization config files. - -Init files are loaded early, just after Doom core, and before modules' config -files. They are always loaded, even in non-interactive sessions, and before -`doom-before-modules-init-hook'. Related to `doom-module-config-file'.") - -(defvar doom-module-config-file "config.el" - "The filename for module configuration files. - -Config files are loaded later, and almost always in interactive sessions. These -run before `doom-after-modules-config-hook' and after `doom-module-init-file'.") - -(defvar doom-module-packages-file "packages.el" - "The filename for the package configuration file. - -Package files are read whenever Doom's package manager wants a manifest of all -desired packages. They are rarely read in interactive sessions (unless the user -uses a straight or package.el command directly).") - -(defvar doom-module-metadata-file ".doommodule" - "The filename for a module's metadata file. - -NOT IMPLEMENTED YET. This file contains a module's metadata: their version, -maintainers, checks, features, submodules, debug information, etc. And are used -to locate modules in the user's file tree.") - -;; DEPRECATED: Remove in v3, as it will be handled in the CLI -(make-obsolete-variable 'doom-obsolete-modules nil "3.0.0") -(defconst doom-obsolete-modules - '((:feature (version-control (:emacs vc) (:ui vc-gutter)) - (spellcheck (:checkers spell)) - (syntax-checker (:checkers syntax)) - (evil (:editor evil)) - (snippets (:editor snippets)) - (file-templates (:editor file-templates)) - (workspaces (:ui workspaces)) - (eval (:tools eval)) - (lookup (:tools lookup)) - (debugger (:tools debugger))) - (:tools (rotate-text (:editor rotate-text)) - (vterm (:term vterm)) - (password-store (:tools pass)) - (flycheck (:checkers syntax)) - (flyspell (:checkers spell)) - (macos (:os macos))) - (:emacs (electric-indent (:emacs electric)) - (hideshow (:editor fold)) - (eshell (:term eshell)) - (term (:term term))) - (:ui (doom-modeline (:ui modeline)) - (fci (:ui fill-column)) - (evil-goggles (:ui ophints)) - (tabbar (:ui tabs)) - (pretty-code (:ui ligatures))) - (:app (email (:email mu4e)) - (notmuch (:email notmuch))) - (:lang (perl (:lang raku)))) - "A tree alist that maps deprecated modules to their replacement(s). - -Each entry is a three-level tree. For example: - - (:feature (version-control (:emacs vc) (:ui vc-gutter)) - (spellcheck (:checkers spell)) - (syntax-checker (:tools flycheck))) - -This marks :feature version-control, :feature spellcheck and :feature -syntax-checker modules obsolete. e.g. If :feature version-control is found in -your `doom!' block, a warning is emitted before replacing it with :emacs vc and -:ui vc-gutter.") - -(make-obsolete-variable 'doom-inhibit-module-warnings nil "3.0.0") -(defvar doom-inhibit-module-warnings (not noninteractive) - "If non-nil, don't emit deprecated or missing module warnings at startup.") - -;;; Custom hooks -(defcustom doom-before-modules-init-hook nil - "Hooks run before module init.el files are loaded." - :group 'doom - :type 'hook) - -(defcustom doom-after-modules-init-hook nil - "Hooks run after module init.el files are loaded." - :group 'doom - :type 'hook) - -(defcustom doom-before-modules-config-hook nil - "Hooks run before module config.el files are loaded." - :group 'doom - :type 'hook) - -(defcustom doom-after-modules-config-hook nil - "Hooks run after module config.el files are loaded (but before the user's)." - :group 'doom - :type 'hook) - - -;; -;;; Types - -(cl-defstruct doom-module - "TODO" - (index 0 :read-only t) - ;; source - group - name - depth - flags - features - ;; sources - path - ;; disabled-p - ;; frozen-p - ;; layer-p - ;; recipe - ;; alist - ;; package - ;; if - ) - -(cl-defstruct doom-module-context - "Hot cache object for the containing Doom module." - index key path flags features) - - -;; -;;; `doom-module-context' - -(defvar doom-module-context (make-doom-module-context) - "A `doom-module-context' for the module associated with the current file. - -Never set this variable directly, use `with-doom-module'.") - -(defmacro with-doom-module (key &rest body) - "Evaluate BODY with `doom-module-context' informed by KEY." - (declare (indent 1)) - `(let ((doom-module-context (doom-module-context ,key))) - (doom-log ":context:module: =%s" doom-module-context) - ,@body)) - -(defun doom-module-context (key) - "Return a `doom-module-context' from KEY. - -KEY can be a `doom-module-context', `doom-module', or a `doom-module-key' cons -cell." - (declare (side-effect-free t)) - (or (pcase (type-of key) - (`doom-module-context key) - (`doom-module (ignore-errors (doom-module->context key))) - (`cons (doom-module (car key) (cdr key)))) - (make-doom-module-context :key (doom-module-key key)))) - -(defun doom-module<-context (context) - "Return a `doom-module' plist from CONTEXT." - (declare (side-effect-free t)) - (doom-module-get (doom-module-context-key context))) - -(defun doom-module->context (key) - "Change a `doom-module' into a `doom-module-context'." - (declare (side-effect-free t)) - (pcase-let - (((doom-module index path flags group name) - (if (doom-module-p key) - key (doom-module-get (doom-module-key key))))) - (make-doom-module-context - :index index - :key (cons group name) - :path path - :flags flags))) - -(defun doom-module (group name &optional property) - "Return the `doom-module-context' for any active module by GROUP NAME. - -Return its PROPERTY, if specified." - (declare (side-effect-free t)) - (when-let ((context (get group name))) - (if property - (aref - context - (or (plist-get - (eval-when-compile - (cl-loop with i = 1 - for info in (cdr (cl-struct-slot-info 'doom-module-context)) - nconc (list (doom-keyword-intern (symbol-name (car info))) - (prog1 i (cl-incf i))))) - property) - (error "Unknown doom-module-context property: %s" property))) - context))) - - -;; -;;; Module API - -(defun doom-modules-initialize (&optional force?) - "Initializes module metadata." - (when (or (null doom-modules) force?) - (setq doom-modules (make-hash-table :test 'equal)) - ;; Register Doom's two virtual module categories, representing Doom's core - ;; and the user's config; which are always enabled. - (doom-module--put '(:doom . nil) :path doom-core-dir :depth -110) - (doom-module--put '(:user . nil) :path doom-user-dir :depth '(-105 . 105)) - ;; DEPRECATED: I intend to phase out our internal usage of `use-package' and - ;; move it to a :config use-package module. The macro is far too complex - ;; and magical for our needs, but until this move is done, ':config - ;; use-package' will remain a hardcoded module for backwards - ;; compatibility. - (doom-module--put '(:config . use-package) - :path (doom-module-locate-path '(:config . use-package)) - :depth -111) - ;; Load $DOOMDIR/init.el, where the user's `doom!' lives, which will inform - ;; us of all desired modules. - (doom-load (file-name-concat doom-user-dir doom-module-init-file) - 'noerror))) - -(defun doom-module-key (key) - "Normalize KEY into a (GROUP . MODULE) tuple representing a Doom module key." - (declare (pure t) (side-effect-free t)) - (cond ((doom-module-p key) - (cons (doom-module-group key) (doom-module-name key))) - ((doom-module-context-p key) - (doom-module-context-key key)) - ((car-safe key) - (if (nlistp (cdr-safe key)) - key - (cons (car key) (cadr key)))) - ((error "Invalid key: %S" key)))) - -(defun doom-module--has-flag-p (flags wanted-flags) - "Return t if the list of WANTED-FLAGS satisfies the list of FLAGS." - (declare (pure t) (side-effect-free error-free)) - (cl-loop with flags = (ensure-list flags) - for flag in (ensure-list wanted-flags) - for flagstr = (symbol-name flag) - if (if (eq ?- (aref flagstr 0)) - (memq (intern (concat "+" (substring flagstr 1))) - flags) - (not (memq flag flags))) - return nil - finally return t)) - -(defun doom-module--fold-flags (flags) - "Returns a collapsed list of FLAGS (a list of +/- prefixed symbols). - -FLAGS is read in sequence, cancelling out negated flags and removing -duplicates." - (declare (pure t) (side-effect-free error-free)) - (let (newflags) - (while flags - (let* ((flag (car flags)) - (flagstr (symbol-name flag))) - (when-let ((sym (intern-soft - (concat (if (eq ?- (aref flagstr 0)) "+" "-") - (substring flagstr 1))))) - (setq newflags (delq sym newflags))) - (cl-pushnew flag newflags :test 'eq)) - (setq flags (cdr flags))) - (nreverse newflags))) - -(defun doom-module-get (key &optional property) - "Returns the plist for GROUP MODULE. Gets PROPERTY, specifically, if set." - (declare (side-effect-free t)) - (when-let ((m (gethash key doom-modules))) - (if property - (aref - m (or (plist-get - (eval-when-compile - (cl-loop with i = 1 - for info in (cdr (cl-struct-slot-info 'doom-module)) - nconc (list (doom-keyword-intern (symbol-name (car info))) - (prog1 i (cl-incf i))))) - property) - (error "Unknown doom-module property: %s" property))) - m))) - -(cl-defun doom-module--put ((group . name) &rest plist) - "Enable GROUP NAME and associate PLIST with it. - -This enables the target module, where GROUP is a keyword, NAME is a symbol, and -PLIST is a property list accepting none, any, or all of the following -properties: - - :group KEYWORD - Indicating the group this module is in. This doesn't have to match GROUP, as - it could indicate a module alias. - :name SYMBOL - Indicating the name of this module. This doesn't have to match NAME, as it - could indicate a module alias. - :path STRING - Path to the directory where this module lives. - :depth INT|(INITDEPTH . CONFIGDEPTH) - Determines module load order. If a cons cell, INITDEPTH determines the load - order of the module's init.el, while CONFIGDEPTH determines the same for all - other config files (config.el, packages.el, doctor.el, etc). - :flags (SYMBOL...) - A list of activated flags for this module. Will be collapsed into - pre-existing flags for the module. - :features (SYMBOL...) - A list of active features, determined from the module's metadata. Will be - collapsed into any pre-existing features for the module. NOT IMPLEMENTED - YET. - -\(fn (GROUP . NAME) &key GROUP NAME PATH DEPTH FLAGS FEATURES)" - (let ((module - (make-doom-module - :index (hash-table-count doom-modules) - :group (or (plist-get plist :group) group) - :name (or (plist-get plist :name) name) - :path (plist-get plist :path) - :flags (plist-get plist :flags) - :features () ; TODO - :depth - (if (not (plist-member plist :depth)) - '(0 . 0) - (let ((depth (plist-get plist :depth))) - (cl-check-type depth (or integer cons)) - (cond ((integerp depth) (cons depth depth)) - ((consp depth) (cons (or (car depth) 0) - (or (cdr depth) 0))) - ((error "Invalid DEPTH value: %S" depth)))))))) - (doom-log 2 "module-put: %s" module) - (prog1 (puthash (cons group name) module doom-modules) - ;; PERF: Doom caches module index, flags, and features in symbol plists - ;; for fast lookups in `modulep!' and elsewhere. plists are lighter and - ;; faster than hash tables for datasets this size, and this information - ;; is looked up *very* often. - (put group name (doom-module->context module))))) - -(defun doom-module-active-p (group module &optional flags) - "Return t if GROUP MODULE is active, and with FLAGS (if given)." - (declare (side-effect-free t)) - (when-let ((val (doom-module-get (cons group module) (if flags :flags)))) - (or (null flags) - (doom-module--has-flag-p flags val)))) - -(defun doom-module-exists-p (group module) - "Returns t if GROUP MODULE is present in any active source." - (declare (side-effect-free t)) - (if (doom-module-get group module) t)) - -(cl-defun doom-module--depth< (keya keyb &optional initorder?) - "Return t if module with KEY-A comes before another with KEY-B. - -If INITORDER? is non-nil, grab the car of the module's :depth, rather than it's -cdr. See `doom-module-put' for details about the :depth property." - (declare (pure t) (side-effect-free t)) - (let* ((adepth (doom-module-get keya :depth)) - (bdepth (doom-module-get keyb :depth)) - (adepth (if initorder? (car adepth) (cdr adepth))) - (bdepth (if initorder? (car bdepth) (cdr bdepth)))) - (if (or (null adepth) (null bdepth) - (= adepth bdepth)) - (< (or (doom-module-get keya :index) 0) - (or (doom-module-get keyb :index) 0)) - (< adepth bdepth)))) - -(defun doom-module-list (&optional paths-or-all initorder?) - "Return a list of (:group . name) module keys in order of their :depth. - -PATHS-OR-ALL can either be a non-nil value or a list of directories. If given a -list of directories, return a list of module keys for all modules present -underneath it. If non-nil, return the same, but search `doom-module-load-path' -(includes :doom and :user). Modules that are enabled are sorted first by their -:depth, followed by disabled modules in lexicographical order (unless a :depth -is specified in their .doommodule). - -If INITORDER? is non-nil, sort modules by the CAR of that module's :depth." - (sort (if paths-or-all - (delete-dups - (append (seq-remove #'cdr (doom-module-list nil initorder?)) - (doom-files-in (if (listp paths-or-all) - paths-or-all - doom-module-load-path) - :map #'doom-module-from-path - :type 'dirs - :mindepth 1 - :depth 1))) - (hash-table-keys doom-modules)) - (doom-rpartial #'doom-module--depth< initorder?))) - -(defun doom-module-expand-path (key &optional file) - "Expands a path to FILE relative to KEY, a cons cell: (GROUP . NAME) - -GROUP is a keyword. MODULE is a symbol. FILE is an optional string path. -If the group isn't enabled this returns nil. For finding disabled modules use -`doom-module-locate-path' instead." - (when-let ((path (doom-module-get key :path))) - (if file - (file-name-concat path file) - path))) - -(defun doom-module-locate-path (key &optional file) - "Searches `doom-module-load-path' to find the path to a module by KEY. - -KEY is a cons cell (GROUP . NAME), where GROUP is a keyword (e.g. :lang) and -NAME is a symbol (e.g. \\='python). FILE is a string that will be appended to -the resulting path. If said path doesn't exist, this returns nil, otherwise an -absolute path." - (let (file-name-handler-alist) - (if-let ((path (doom-module-expand-path key file))) - (if (or (null file) - (file-exists-p path)) - path) - (cl-destructuring-bind (group . module) (doom-module-key key) - (let* ((group (doom-keyword-name group)) - (module (if module (symbol-name module))) - (path (file-name-concat group module file))) - (if file - ;; PERF: locate-file-internal is a little faster for finding files, - ;; but its interface for finding directories is clumsy. - (locate-file-internal path doom-module-load-path '("" ".elc" ".el")) - (cl-loop for default-directory in doom-module-load-path - if (file-exists-p path) - return (expand-file-name path)))))))) - -(defun doom-module-locate-paths (module-list file) - "Return all existing paths to FILE under each module in MODULE-LIST. - -MODULE-LIST is a list of cons cells (GROUP . NAME). See `doom-module-list' for -an example." - (cl-loop for key in (or module-list (doom-module-list)) - if (doom-module-locate-path key file) - collect it)) - -(defun doom-module-from-path (path &optional enabled-only?) - "Returns a cons cell (GROUP . NAME) derived from PATH (a file path). -If ENABLED-ONLY?, return nil if the containing module isn't enabled." - (let* ((file-name-handler-alist nil) - (path (expand-file-name path))) - (save-match-data - (cond ((string-match "/modules/\\([^/]+\\)/\\([^/]+\\)\\(?:/.*\\)?$" path) - (when-let* ((group (doom-keyword-intern (match-string 1 path))) - (name (intern (match-string 2 path)))) - (and (or (null enabled-only?) - (doom-module-active-p group name)) - (cons group name)))) - ((file-in-directory-p path doom-core-dir) - (cons :doom nil)) - ((file-in-directory-p path doom-user-dir) - (cons :user nil)))))) - -(defun doom-module-load-path (&optional module-load-path) - "Return a list of file paths to activated modules. - -The list is in no particular order and its file paths are absolute. If -MODULE-DIRS is non-nil, include all modules (even disabled ones) available in -those directories." - (declare (pure t) (side-effect-free t)) - (mapcar #'doom-module-locate-path - (doom-module-list (or module-load-path doom-module-load-path)))) - -(defun doom-module-mplist-map (fn mplist) - "Apply FN to each module in MPLIST." - (let ((mplist (copy-sequence mplist)) - (inhibit-message doom-inhibit-module-warnings) - obsolete - results - group m) - (while mplist - (setq m (pop mplist)) - (cond ((keywordp m) - (setq group m - obsolete (assq m doom-obsolete-modules))) - ((null group) - (error "No module group specified for %s" m)) - ((and (listp m) (keywordp (car m))) - (pcase (car m) - (:cond - (cl-loop for (cond . mods) in (cdr m) - if (eval cond t) - return (prependq! mplist mods))) - (:if (if (eval (cadr m) t) - (push (caddr m) mplist) - (prependq! mplist (cdddr m)))) - (test (if (xor (eval (cadr m) t) - (eq test :unless)) - (prependq! mplist (cddr m)))))) - ((catch 'doom-modules - (let* ((module (if (listp m) (car m) m)) - (flags (if (listp m) (cdr m)))) - (when-let (new (assq module obsolete)) - (let ((newkeys (cdr new))) - (if (null newkeys) - (print! (warn "%s module was removed")) - (if (cdr newkeys) - (print! (warn "%s module was removed and split into the %s modules") - (list group module) - (mapconcat #'prin1-to-string newkeys ", ")) - (print! (warn "%s module was moved to %s") - (list group module) - (car newkeys))) - (push group mplist) - (dolist (key newkeys) - (push (if flags - (nconc (cdr key) flags) - (cdr key)) - mplist) - (push (car key) mplist)) - (throw 'doom-modules t)))) - (doom-log "module: %s %s %s -> %s" group module (or flags "") - (doom-module-locate-path (cons group module))) - (push (funcall fn (cons group module) - :flags (if (listp m) (cdr m)) - :path (doom-module-locate-path (cons group module))) - results)))))) - (when noninteractive - (setq doom-inhibit-module-warnings t)) - (nreverse results))) - - -;; -;;; Module config macros - -(put :if 'lisp-indent-function 2) -(put :when 'lisp-indent-function 'defun) -(put :unless 'lisp-indent-function 'defun) - -(defmacro doom! (&rest modules) - "Bootstraps DOOM Emacs and its modules. - -If the first item in MODULES doesn't satisfy `keywordp', MODULES is evaluated, -otherwise, MODULES is a variadic-property list (a plist whose key may be -followed by one or more values). - -This macro does nothing in interactive sessions, but in noninteractive session -iterates through MODULES, enabling and initializing them. The order of modules -in these blocks dictates their load order (unless given an explicit :depth)." - `(when noninteractive - (doom-module-mplist-map - #'doom-module--put - ,@(if (keywordp (car modules)) - (list (list 'quote modules)) - modules)) - t)) - -;; DEPRECATED Remove in 3.0 -(define-obsolete-function-alias 'featurep! 'modulep! "3.0.0") - -(defmacro modulep! (group &optional module &rest flags) - "Return t if :GROUP MODULE (and +FLAGS) are enabled. - -If FLAGS is provided, returns t if GROUP MODULE has all of FLAGS enabled. - - (modulep! :config default +flag) - (modulep! :config default +flag1 +flag2 +flag3) - -GROUP and MODULE may be omitted when this macro is used from a Doom module's -source (except your $DOOMDIR, which is a special module). Like so: - - (modulep! +flag3 +flag1 +flag2) - (modulep! +flag) - -FLAGS can be negated. E.g. This will return non-nil if ':tools lsp' is enabled -without `+eglot': - - (modulep! :tools lsp -eglot) - -To interpolate dynamic values, use comma: - - (let ((flag '-eglot)) - (modulep! :tools lsp ,flag)) - -For more about modules and flags, see `doom!'." - (if (keywordp group) - (if flags - `(doom-module--has-flag-p - (doom-module (backquote ,group) (backquote ,module) :flags) - (backquote ,flags)) - `(and (get (backquote ,group) (backquote ,module)) t)) - (let ((flags (delq nil (cons group (cons module flags))))) - (if (doom-module-context-index doom-module-context) - `(doom-module--has-flag-p - ',(doom-module-context-flags doom-module-context) - (backquote ,flags)) - `(let ((file (file!))) - (if-let ((module (doom-module-from-path file))) - (doom-module--has-flag-p - (doom-module (car module) (cdr module) :flags) - (backquote ,flags)) - (error "(modulep! %s) couldn't resolve current module from %s" - (backquote ,flags) (abbreviate-file-name file)))))))) - -(provide 'doom-modules) -;;; doom-modules.el ends here diff --git a/lisp/doom-packages.el b/lisp/doom-packages.el deleted file mode 100644 index 48d49320f..000000000 --- a/lisp/doom-packages.el +++ /dev/null @@ -1,648 +0,0 @@ -;;; lisp/doom-packages.el -*- lexical-binding: t; -*- -;;; Commentary: -;; -;; Emacs package management is opinionated, and so is Doom. Doom uses `straight' -;; to create a declarative, lazy-loaded, and (nominally) reproducible package -;; management system. We use `straight' over `package' because the latter is -;; tempermental. ELPA sources suffer downtime occasionally and often fail to -;; build packages when GNU Tar is unavailable (e.g. MacOS users start with BSD -;; tar). Known gnutls errors plague the current stable release of Emacs (26.x) -;; which bork TLS handshakes with ELPA repos (mainly gnu.elpa.org). See -;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=3434. -;; -;; What's worse, you can only get the latest version of packages through ELPA. -;; In an ecosystem that is constantly changing, this is more frustrating than -;; convenient. Straight (and Doom) can do rolling release, but it is opt-in. -;; -;; Interacting with this package management system is done through Doom's -;; bin/doom script. Find out more about it by running 'doom help' (I highly -;; recommend you add the script to your PATH). Here are some highlights: -;; -;; - `doom install`: a wizard that guides you through setting up Doom and your -;; private config for the first time. -;; - `doom sync`: your go-to command for making sure Doom is in optimal -;; condition. It ensures all unneeded packages are removed, all needed ones -;; are installed, and all metadata associated with them is generated. -;; - `doom upgrade`: upgrades Doom Emacs and your packages to the latest -;; versions. There's also 'bin/doom sync -u' for updating only your packages. -;; -;; How this works is: the system reads packages.el files located in each -;; activated module, your private config (`doom-user-dir'), and one in -;; `doom-core-dir'. These contain `package!' declarations that tell DOOM what -;; packages to install and where from. -;; -;; All that said, you can still use package.el's commands, but 'doom sync' will -;; purge ELPA packages. -;; -;;; Code: - -(defvar doom-packages () - "A list of enabled packages. Each element is a sublist, whose CAR is the -package's name as a symbol, and whose CDR is the plist supplied to its -`package!' declaration. Set by `doom-initialize-packages'.") - -(defvar doom-disabled-packages () - "A list of packages that should be ignored by `use-package!' and `after!'.") - -(defvar doom-packages-file "packages" - "The basename of packages file for modules. - -Package files are read whenever Doom's package manager wants a manifest of all -desired packages. They are rarely read in interactive sessions (unless the user -uses a straight or package.el command directly).") - - -;; -;;; package.el - -;; Ensure that, if we do need package.el, it is configured correctly. You really -;; shouldn't be using it, but it may be convenient for quickly testing packages. -(setq package-enable-at-startup nil - package-user-dir (concat doom-local-dir "elpa/") - package-gnupghome-dir (expand-file-name "gpg" package-user-dir)) - -(after! package - (let ((s (if gnutls-verify-error "s" ""))) - (prependq! package-archives - ;; I omit Marmalade because its packages are manually submitted - ;; rather than pulled, and so often out of date. - `(("melpa" . ,(format "http%s://melpa.org/packages/" s)) - ("org" . ,(format "http%s://orgmode.org/elpa/" s)))))) - -;; Refresh package.el the first time you call `package-install', so it can still -;; be used (e.g. to temporarily test packages). Remember to run 'doom sync' to -;; purge them; they can conflict with packages installed via straight! -(add-transient-hook! 'package-install (package-refresh-contents)) - - -;; -;;; Straight - -(setq straight-base-dir (file-truename doom-local-dir) - straight-repository-branch "develop" - ;; Since byte-code is rarely compatible across different versions of - ;; Emacs, it's best we build them in separate directories, per emacs - ;; version. - straight-build-dir (format "build-%s" emacs-version) - straight-cache-autoloads nil ; we already do this, and better. - ;; Doom doesn't encourage you to modify packages in place. Disabling this - ;; makes 'doom sync' instant (once everything set up), which is much nicer - ;; UX than the several seconds modification checks. - straight-check-for-modifications nil - ;; We handle package.el ourselves (and a little more comprehensively) - straight-enable-package-integration nil - ;; Before switching to straight, `doom-local-dir' would average out at - ;; around 100mb with half Doom's modules at ~230 packages. Afterwards, at - ;; around 1gb. With shallow cloning, that is reduced to ~400mb. This has - ;; no affect on packages that are pinned, however (run 'doom purge' to - ;; compact those after-the-fact). Some packages break when shallow cloned - ;; (like magit and org), but we'll deal with that elsewhere. - straight-vc-git-default-clone-depth '(1 single-branch)) - -(with-eval-after-load 'straight - ;; HACK: Doom relies on deferred compilation, which spares the user 20-50min - ;; of compilation at install time, but subjects them to ~50% CPU activity - ;; when starting Emacs for the first time. To complete this, straight.el - ;; needs to be told not to do native-compilation, but it won't obey - ;; `straight-disable-native-compile'. - ;; - ;; It *will* obey `straight--native-comp-available', though. Trouble is: - ;; it's a constant; it resets itself when straight is loaded, so it must be - ;; changed afterwards. - (setq straight--native-comp-available nil) - ;; `let-alist' is built into Emacs 26 and onwards - (add-to-list 'straight-built-in-pseudo-packages 'let-alist)) - -(defadvice! doom--read-pinned-packages-a (fn &rest args) - "Read `:pin's in `doom-packages' on top of straight's lockfiles." - :around #'straight--lockfile-read-all - (append (apply fn args) ; lockfiles still take priority - (doom-package-pinned-list))) - -;; HACK: This fixes an issue introduced in emacs-mirror/emacs@0d383b592c2f and -;; is present in >=29: Straight.el uses `loaddefs-generate' if it is -;; available, which activates `emacs-lisp-mode' to read autoloads files, but -;; does so without suppressing its hooks. Some packages (like overseer) add -;; hooks to `emacs-lisp-mode-hook' in their autoloads, and once triggered, -;; they will try to load their dependencies (like dash or pkg-info), causing -;; file errors. -;; REVIEW: Report this upstream. -(defadvice! doom--fix-loaddefs-generate--parse-file-a (fn &rest args) - :around #'loaddefs-generate--parse-file - (let (emacs-lisp-mode-hook) - (apply fn args))) - - -;; -;;; native-comp - -(when (featurep 'native-compile) - (after! comp - ;; HACK Disable native-compilation for some troublesome packages - (mapc (doom-partial #'add-to-list 'native-comp-deferred-compilation-deny-list) - (list "/seq-tests\\.el\\'" - "/emacs-jupyter.*\\.el\\'" - "/evil-collection-vterm\\.el\\'" - "/vterm\\.el\\'" - "/with-editor\\.el\\'")))) - - -;; -;;; Bootstrappers - -(defun doom--ensure-straight (recipe pin) - (letenv! (("GIT_CONFIG" nil) - ("GIT_CONFIG_NOSYSTEM" "1") - ("GIT_CONFIG_GLOBAL" (or (getenv "DOOMGITCONFIG") - "/dev/null"))) - (let ((repo-dir (doom-path straight-base-dir "straight/repos/straight.el")) - (repo-url (concat "http" (if gnutls-verify-error "s") - "://github.com/" - (or (plist-get recipe :repo) "radian-software/straight.el"))) - (branch (or (plist-get recipe :branch) straight-repository-branch)) - (call (if init-file-debug - (lambda (&rest args) - (print! "%s" (cdr (apply #'doom-call-process args)))) - (lambda (&rest args) - (apply #'doom-call-process args))))) - (unless (file-directory-p repo-dir) - (save-match-data - (unless (executable-find "git") - (user-error "Git isn't present on your system. Cannot proceed.")) - (let* ((version (cdr (doom-call-process "git" "version"))) - (version - (and (string-match "\\_<[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)\\_>" version) - (match-string 0 version)))) - (if version - (when (version< version "2.23") - (user-error "Git %s detected! Doom requires git 2.23 or newer!" - version))))) - (print! (start "Installing straight...")) - (print-group! - (cl-destructuring-bind (depth . options) - (ensure-list straight-vc-git-default-clone-depth) - (let ((branch-switch (if (memq 'single-branch options) - "--single-branch" - "--no-single-branch"))) - (cond - ((eq 'full depth) - (funcall call "git" "clone" "--origin" "origin" - branch-switch repo-url repo-dir)) - ((integerp depth) - (if (null pin) - (progn - (when (file-directory-p repo-dir) - (delete-directory repo-dir 'recursive)) - (funcall call "git" "clone" "--origin" "origin" repo-url - "--no-checkout" repo-dir - "--depth" (number-to-string depth) - branch-switch - "--no-tags" - "--branch" straight-repository-branch)) - (make-directory repo-dir 'recursive) - (let ((default-directory repo-dir)) - (funcall call "git" "init") - (funcall call "git" "branch" "-m" straight-repository-branch) - (funcall call "git" "remote" "add" "origin" repo-url - "--master" straight-repository-branch) - (funcall call "git" "fetch" "origin" pin - "--depth" (number-to-string depth) - "--no-tags") - (funcall call "git" "reset" "--hard" pin))))))))) - (require 'straight (concat repo-dir "/straight.el")) - (doom-log "Initializing recipes") - (mapc #'straight-use-recipes - '((org-elpa :local-repo nil) - (melpa :type git :host github - :repo "melpa/melpa" - :build nil) - (nongnu-elpa :type git - :repo "https://git.savannah.gnu.org/git/emacs/nongnu.git" - :local-repo "nongnu-elpa" - :build nil) - (gnu-elpa-mirror :type git :host github - :repo "emacs-straight/gnu-elpa-mirror" - :build nil) - (el-get :type git :host github - :repo "dimitri/el-get" - :build nil) - (emacsmirror-mirror :type git :host github - :repo "emacs-straight/emacsmirror-mirror" - :build nil)))))) - -(defun doom--ensure-core-packages (packages) - (doom-log "Installing core packages") - (dolist (package packages) - (let* ((name (car package)) - (repo (symbol-name name))) - (when-let (recipe (plist-get (cdr package) :recipe)) - (straight-override-recipe (cons name recipe)) - (when-let (local-repo (plist-get recipe :local-repo)) - (setq repo local-repo))) - (print-group! - ;; Only clone the package, don't build them. Straight hasn't been fully - ;; configured by this point. - (straight-use-package name nil t)) - ;; In case the package hasn't been built yet. - (or (member (directory-file-name (straight--build-dir (symbol-name name))) - load-path) - (add-to-list 'load-path (directory-file-name (straight--repos-dir repo))))))) - -(defun doom-initialize-core-packages (&optional force-p) - "Ensure `straight' is installed and was compiled with this version of Emacs." - (when (or force-p (null (bound-and-true-p straight-recipe-repositories))) - (doom-log "Initializing straight") - (let ((packages (doom-package-list '((:doom))))) - (cl-destructuring-bind (&key recipe pin &allow-other-keys) - (alist-get 'straight packages) - (doom--ensure-straight recipe pin)) - (doom--ensure-core-packages - (seq-filter (fn! (eq (plist-get (cdr %) :type) 'core)) - packages))))) - -(defun doom-initialize-packages (&optional force-p) - "Process all packages, essential and otherwise, if they haven't already been. - -If FORCE-P is non-nil, do it anyway. - -This ensures `doom-packages' is populated and `straight' recipes are properly -processed." - (doom-initialize-core-packages force-p) - (when (or force-p (not (bound-and-true-p package--initialized))) - (doom-log "Initializing package.el") - (require 'package) - (package-initialize) - (unless package--initialized - (error "Failed to initialize package.el"))) - (when (or force-p (null doom-packages)) - (doom-log "Initializing straight.el") - (setq doom-disabled-packages nil - doom-packages (doom-package-list)) - (let (packages) - (dolist (package doom-packages) - (cl-destructuring-bind - (name &key recipe disable ignore &allow-other-keys) package - (if ignore - (straight-override-recipe (cons name '(:type built-in))) - (if disable - (cl-pushnew name doom-disabled-packages) - (when recipe - (straight-override-recipe (cons name recipe))) - (appendq! packages (cons name (straight--get-dependencies name))))))) - (dolist (package (cl-delete-duplicates packages :test #'equal)) - (straight-register-package package) - (let ((name (symbol-name package))) - (add-to-list 'load-path (directory-file-name (straight--build-dir name))) - (straight--load-package-autoloads name)))))) - - -;; -;;; Package management API - -(defun doom-package-get (package &optional prop nil-value) - "Returns PACKAGE's `package!' recipe from `doom-packages'." - (let ((plist (cdr (assq package doom-packages)))) - (if prop - (if (plist-member plist prop) - (plist-get plist prop) - nil-value) - plist))) - -(defun doom-package-set (package prop value) - "Set PROPERTY in PACKAGE's recipe to VALUE." - (setf (alist-get package doom-packages) - (plist-put (alist-get package doom-packages) - prop value))) - -(defun doom-package-recipe (package &optional prop nil-value) - "Returns the `straight' recipe PACKAGE was registered with." - (let* ((recipe (straight-recipes-retrieve package)) - (plist (doom-plist-merge - (plist-get (alist-get package doom-packages) :recipe) - (cdr (if (memq (car recipe) '(quote \`)) - (eval recipe t) - recipe))))) - (if prop - (if (plist-member plist prop) - (plist-get plist prop) - nil-value) - plist))) - -(defun doom-package-recipe-repo (package) - "Resolve and return PACKAGE's (symbol) local-repo property." - (if-let* ((recipe (copy-sequence (doom-package-recipe package))) - (recipe (if (and (not (plist-member recipe :type)) - (memq (plist-get recipe :host) '(github gitlab bitbucket))) - (plist-put recipe :type 'git) - recipe)) - (repo (if-let (local-repo (plist-get recipe :local-repo)) - (directory-file-name local-repo) - (ignore-errors (straight-vc-local-repo-name recipe))))) - repo - (symbol-name package))) - -(defun doom-package-build-recipe (package &optional prop nil-value) - "Returns the `straight' recipe PACKAGE was installed with." - (let ((plist (nth 2 (gethash (symbol-name package) straight--build-cache)))) - (if prop - (if (plist-member plist prop) - (plist-get plist prop) - nil-value) - plist))) - -(defun doom-package-dependencies (package &optional recursive noerror) - "Return a list of dependencies for a package. - -If RECURSIVE is `tree', return a tree of dependencies. -If RECURSIVE is nil, only return PACKAGE's immediate dependencies. -If NOERROR, return nil in case of error." - (cl-check-type package symbol) - (let ((deps (straight-dependencies (symbol-name package)))) - (pcase recursive - (`tree deps) - (`t (flatten-list deps)) - (`nil (cl-remove-if #'listp deps))))) - -(defun doom-package-depending-on (package &optional noerror) - "Return a list of packages that depend on PACKAGE. - -If PACKAGE (a symbol) isn't installed, throw an error, unless NOERROR is -non-nil." - (cl-check-type package symbol) - ;; can't get dependencies for built-in packages - (unless (or (doom-package-build-recipe package) - noerror) - (error "Couldn't find %s, is it installed?" package)) - (straight-dependents (symbol-name package))) - -;;; Predicate functions -(defun doom-package-built-in-p (package) - "Return non-nil if PACKAGE (a symbol) is built-in." - (eq (doom-package-build-recipe package :type) - 'built-in)) - -(defun doom-package-installed-p (package) - "Return non-nil if PACKAGE (a symbol) is installed." - (file-directory-p (straight--build-dir (symbol-name package)))) - -(defun doom-package-is-type-p (package type) - "TODO" - (memq type (ensure-list (doom-package-get package :type)))) - -(defun doom-package-in-module-p (package category &optional module) - "Return non-nil if PACKAGE was installed by the user's private config." - (when-let (modules (doom-package-get package :modules)) - (or (and (not module) (assq :user modules)) - (member (cons category module) modules)))) - -(defun doom-package-backend (package) - "Return 'straight, 'builtin, 'elpa or 'other, depending on how PACKAGE is -installed." - (cond ((gethash (symbol-name package) straight--build-cache) - 'straight) - ((or (doom-package-built-in-p package) - (assq package package--builtins)) - 'builtin) - ((assq package package-alist) - 'elpa) - ((locate-library (symbol-name package)) - 'other))) - - -;;; Package getters -(defun doom-packages--read (file &optional noeval noerror) - (condition-case-unless-debug e - (with-temp-buffer ; prevent buffer-local state from propagating - (if (not noeval) - (load file noerror 'nomessage 'nosuffix) - (when (file-exists-p file) - (insert-file-contents file) - (with-syntax-table emacs-lisp-mode-syntax-table - ;; Scrape `package!' blocks from FILE for a comprehensive listing of - ;; packages used by this module. - (while (search-forward "(package!" nil t) - (let ((ppss (save-excursion (syntax-ppss)))) - ;; Don't collect packages in comments or strings - (unless (or (nth 3 ppss) - (nth 4 ppss)) - (goto-char (match-beginning 0)) - (cl-destructuring-bind (_ name . plist) - (read (current-buffer)) - (push (cons - name (plist-put - plist :modules - (list (doom-module-context-key doom-module-context)))) - doom-packages))))))))) - (user-error - (user-error (error-message-string e))) - (error - (signal 'doom-package-error - (list (doom-module-context-key doom-module-context) - file e))))) - -(defun doom-package-list (&optional module-list) - "Retrieve a list of explicitly declared packages from MODULE-LIST. - -If MODULE-LIST is omitted, read enabled module list in configdepth order (see -`doom-module-set'). Otherwise, MODULE-LIST may be any symbol (or t) to mean read -all modules in `doom-modules-dir', including :doom and :user. MODULE-LIST may -also be a list of module keys." - (let ((module-list (cond ((null module-list) (doom-module-list)) - ((symbolp module-list) (doom-module-list 'all)) - (module-list))) - (packages-file doom-module-packages-file) - doom-disabled-packages - doom-packages) - (letf! (defun read-packages (key) - (with-doom-module key - (when-let (file (doom-module-locate-path - key doom-module-packages-file)) - (doom-packages--read file nil 'noerror)))) - (with-doom-context 'packages - (let ((user? (assq :user module-list))) - (when user? - ;; We load the private packages file twice to populate - ;; `doom-disabled-packages' disabled packages are seen ASAP... - (let (doom-packages) - (read-packages (cons :user nil)))) - (mapc #'read-packages module-list) - ;; ...Then again to ensure privately overriden packages are properly - ;; overwritten. - (if user? (read-packages (cons :user nil))) - (nreverse doom-packages)))))) - -(defun doom-package-pinned-list () - "Return an alist mapping package names (strings) to pinned commits (strings)." - (let (alist) - (dolist (package doom-packages alist) - (cl-destructuring-bind (name &key disable ignore pin unpin &allow-other-keys) - package - (when (and (not ignore) - (not disable) - (or pin unpin)) - (setf (alist-get (file-name-nondirectory (doom-package-recipe-repo name)) - alist nil 'remove #'equal) - (unless unpin pin))))))) - -(defun doom-package-recipe-list () - "Return straight recipes for non-builtin packages with a local-repo." - (let (recipes) - (dolist (recipe (hash-table-values straight--recipe-cache)) - (cl-destructuring-bind (&key local-repo type &allow-other-keys) - recipe - (unless (or (null local-repo) - (eq type 'built-in)) - (push recipe recipes)))) - (nreverse recipes))) - - -;; -;;; Module package macros - -(cl-defmacro package! - (name &rest plist &key built-in recipe ignore _type _pin _disable) - "Declares a package and how to install it (if applicable). - -This macro is declarative and does not load nor install packages. It is used to -populate `doom-packages' with metadata about the packages Doom needs to keep -track of. - -Only use this macro in a module's packages.el file. - -Accepts the following properties: - - :type core|local|built-in|virtual - Specifies what kind of package this is. Can be a symbol or a list thereof. - `core' = this is a protected package and cannot be disabled! - `local' = this package is being modified in-place. This package's repo is - unshallowed and will be skipped when you update packages. - `built-in' = this package is already built-in (otherwise, will be - installed) - `virtual' = this package is not tracked by Doom's package manager. It won't - be installed or uninstalled. Use this to pin 2nd order dependencies. - :recipe RECIPE - Specifies a straight.el recipe to allow you to acquire packages from external - sources. See https://github.com/radian-software/straight.el#the-recipe-format - for details on this recipe. - :disable BOOL - Do not install or update this package AND disable all of its `use-package!' - and `after!' blocks. - :ignore FORM - Do not install this package. - :pin STR|nil - Pin this package to commit hash STR. Setting this to nil will unpin this - package if previously pinned. - :built-in BOOL|'prefer - Same as :ignore if the package is a built-in Emacs package. This is more to - inform help commands like `doom/help-packages' that this is a built-in - package. If set to 'prefer, the package will not be installed if it is - already provided by Emacs. - -Returns t if package is successfully registered, and nil if it was disabled -elsewhere." - (declare (indent defun)) - (when (and recipe (keywordp (car-safe recipe))) - (cl-callf plist-put plist :recipe `(quote ,recipe))) - ;; :built-in t is basically an alias for :ignore (locate-library NAME) - (when built-in - (when (and (not ignore) - (equal built-in '(quote prefer))) - (setq built-in `(locate-library ,(symbol-name name) nil (get 'load-path 'initial-value)))) - (cl-callf map-delete plist :built-in) - (cl-callf plist-put plist :ignore built-in)) - `(let* ((name ',name) - (plist (cdr (assq name doom-packages))) - (dir (dir!)) - (module (doom-module-from-path dir))) - (unless (doom-context-p 'packages) - (signal 'doom-module-error - (list module "package! can only be used in packages.el files"))) - ;; Record what module this declaration was found in - (let ((module-list (plist-get plist :modules))) - (unless (member module module-list) - (cl-callf plist-put plist :modules - (append module-list - (list module) - (when (file-in-directory-p dir doom-user-dir) - '((:user . modules))) - nil)))) - ;; Merge given plist with pre-existing one - (cl-loop for (key value) on (list ,@plist) by 'cddr - when (or (eq key :pin) value) - do (cl-callf plist-put plist key value)) - ;; Some basic key validation; throws an error on invalid properties - (condition-case e - (when-let (recipe (plist-get plist :recipe)) - (cl-destructuring-bind - (&key local-repo _files _flavor _build _pre-build _post-build - _includes _type _repo _host _branch _protocol _remote - _nonrecursive _fork _depth _source _inherit) - recipe - ;; Expand :local-repo from current directory - (when local-repo - (cl-callf plist-put plist :recipe - (plist-put recipe :local-repo - (let ((local-path (expand-file-name local-repo dir))) - (if (file-directory-p local-path) - local-path - local-repo))))))) - (error - (signal 'doom-package-error - (cons ,(symbol-name name) - (error-message-string e))))) - ;; These are the only side-effects of this macro! - (setf (alist-get name doom-packages) plist) - (if (plist-get plist :disable) - (add-to-list 'doom-disabled-packages name) - (with-no-warnings - (cons name plist))))) - -(defmacro disable-packages! (&rest packages) - "A convenience macro for disabling packages in bulk. -Only use this macro in a module's (or your private) packages.el file." - (macroexp-progn - (mapcar (lambda (p) `(package! ,p :disable t)) - packages))) - -(defmacro unpin! (&rest targets) - "Unpin packages in TARGETS. - -This unpins packages, so that `doom upgrade' or `doom sync -u' will update them -to the latest commit available. Some examples: - -- To disable pinning wholesale: (unpin! t) -- To unpin individual packages: (unpin! packageA packageB ...) -- To unpin all packages in a group of modules: (unpin! :lang :tools ...) -- To unpin packages in individual modules: - (unpin! (:lang python javascript) (:tools docker)) - -Or any combination of the above. - -This macro should only be used from the user's private packages.el. No module -should use it!" - (if (memq t targets) - `(mapc (doom-rpartial #'doom-package-set :unpin t) - (mapcar #'car doom-packages)) - (macroexp-progn - (mapcar - (lambda (target) - (when target - `(doom-package-set ',target :unpin t))) - (cl-loop for target in targets - if (or (keywordp target) (listp target)) - append - (cl-loop with (category . modules) = (ensure-list target) - for (name . plist) in doom-packages - for pkg-modules = (plist-get plist :modules) - if (and (assq category pkg-modules) - (or (null modules) - (cl-loop for module in modules - if (member (cons category module) pkg-modules) - return t)) - name) - collect it) - else if (symbolp target) - collect target))))) - -(provide 'doom-packages) -;;; doom-packages.el ends here diff --git a/lisp/doom-start.el b/lisp/doom-start.el index 3cc4b950a..e7b9ad654 100644 --- a/lisp/doom-start.el +++ b/lisp/doom-start.el @@ -270,84 +270,11 @@ If RETURN-P, return the message as a string instead of displaying it." (funcall (if return-p #'format #'message) "Doom loaded %d packages across %d modules in %.03fs" (- (length load-path) (length (get 'load-path 'initial-value))) - (hash-table-count doom-modules) + (if doom-modules (hash-table-count doom-modules) -1) doom-init-time)) ;; -;;; Load Doom's defaults and DSL - -;;; Load core modules and set up their autoloads -(require 'doom-modules) -;; TODO (autoload 'doom-profiles-initialize "doom-profiles") -;; TODO (autoload 'doom-packages-initialize "doom-packages") - -;; UX: There's a chance the user will later use package.el or straight in this -;; interactive session. If they do, make sure they're properly initialized -;; when they do. -(autoload 'doom-initialize-packages "doom-packages") -(with-eval-after-load 'package (require 'doom-packages)) -(with-eval-after-load 'straight (doom-initialize-packages)) - - -;; -;;; Let 'er rip! - -;; A last ditch opportunity to undo dodgy optimizations or do extra -;; configuration before the session is complicated by user config and packages. -(doom-run-hooks 'doom-before-init-hook) - -;;; Load envvar file -;; 'doom env' generates an envvar file. This is a snapshot of your shell -;; environment, which Doom loads here. This is helpful in scenarios where Emacs -;; is launched from an environment detached from the user's shell environment. -(when (and (or initial-window-system - (daemonp)) - doom-env-file) - (doom-load-envvars-file doom-env-file 'noerror)) - -;;; Last minute setup -(add-hook 'doom-after-init-hook #'doom-load-packages-incrementally-h 100) -(add-hook 'doom-after-init-hook #'doom-display-benchmark-h 110) -(doom-run-hook-on 'doom-first-buffer-hook '(find-file-hook doom-switch-buffer-hook)) -(doom-run-hook-on 'doom-first-file-hook '(find-file-hook dired-initial-position-hook)) -(doom-run-hook-on 'doom-first-input-hook '(pre-command-hook)) - -;; If the user's already opened something (e.g. with command-line arguments), -;; then we should assume nothing about the user's intentions and simply treat -;; this session as fully initialized. -(add-hook! 'doom-after-init-hook :depth 100 - (defun doom-run-first-hooks-if-files-open-h () - (when file-name-history - (doom-run-hooks 'doom-first-file-hook 'doom-first-buffer-hook)))) - -;; PERF: Activate these later, otherwise they'll fire for every buffer created -;; between now and the end of startup. -(add-hook! 'after-init-hook - (defun doom-init-local-var-hooks-h () - ;; These fire `MAJOR-MODE-local-vars-hook' hooks, which is a Doomism. See - ;; the `MODE-local-vars-hook' section above. - (add-hook 'after-change-major-mode-hook #'doom-run-local-var-hooks-h 100) - (add-hook 'hack-local-variables-hook #'doom-run-local-var-hooks-h))) - -;;; Load $DOOMDIR/init.el early -;; TODO: Catch errors -(load! (string-remove-suffix ".el" doom-module-init-file) doom-user-dir t) - -;; If the user is loading this file from a batch script, let's assume they want -;; to load their userland config immediately. -(when noninteractive - (doom-require 'doom-profiles) - (let ((init-file (doom-profile-init-file))) - (unless (file-exists-p init-file) - (user-error "Profile init file hasn't been generated. Did you forgot to run 'doom sync'?")) - (let (kill-emacs-query-functions - kill-emacs-hook) - ;; Loads modules, then $DOOMDIR/config.el - (doom-load init-file 'noerror) - (doom-initialize-packages)))) - - ;;; Entry point ;; HACK: This advice hijacks Emacs' initfile loader to accomplish the following: ;; @@ -378,30 +305,30 @@ If RETURN-P, return the message as a string instead of displaying it." ;; Compiling them in one place is a big reduction in startup ;; time, and by keeping a history of them, you get a snapshot ;; of your config in time. - (file-name-concat - doom-profile-dir (format "init.%d.elc" emacs-major-version)))) - ;; If `user-init-file' is t, then `load' will store the name of - ;; the next file it loads into `user-init-file'. - (setq user-init-file t) - (when init-file-name - (load init-file-name 'noerror 'nomessage 'nosuffix) - ;; HACK: if `init-file-name' happens to be higher in - ;; `load-history' than a symbol's actual definition, - ;; `symbol-file' (and help/helpful buffers) will report the - ;; source of a symbol as `init-file-name', rather than it's - ;; true source. By removing this file from `load-history', no - ;; one will make that mistake. - (setq load-history (delete (assoc init-file-name load-history) - load-history))) - ;; If it's still `t', then it failed to load the profile initfile. - ;; This likely means the user has forgotten to run `doom sync'! - (when (eq user-init-file t) - (signal 'doom-nosync-error (list init-file-name))) + (doom-profile-init-file doom-profile))) ;; If we loaded a compiled file, set `user-init-file' to the ;; source version if that exists. (setq user-init-file (concat (string-remove-suffix ".elc" user-init-file) - ".el")))) + ".el")) + ;; HACK: if `init-file-name' happens to be higher in + ;; `load-history' than a symbol's actual definition, + ;; `symbol-file' (and help/helpful buffers) will report the + ;; source of a symbol as `init-file-name', rather than it's true + ;; source. By removing this file from `load-history', no one + ;; will make that mistake. + (setq load-history + (delete (assoc init-file-name load-history) + load-history)) + (let ((startup-or-reload? + (or (doom-context-p 'startup) + (doom-context-p 'reload)))) + (when startup-or-reload? + (doom--startup-vars)) + (doom--startup-module-autoloads) + (doom--startup-package-autoloads) + (when startup-or-reload? + (doom--startup-modules))))) ;; TODO: Add safe-mode profile. ;; (error ;; ;; HACK: This is not really this variable's intended purpose, but it diff --git a/lisp/doom-straight.el b/lisp/doom-straight.el new file mode 100644 index 000000000..13549fa35 --- /dev/null +++ b/lisp/doom-straight.el @@ -0,0 +1,317 @@ +;;; lisp/doom-straight.el -*- lexical-binding: t; -*- +;;; Commentary: +;; +;; Emacs package management is opinionated, and so is Doom. Doom uses `straight' +;; to create a declarative, lazy-loaded, and (nominally) reproducible package +;; management system. We use `straight' over `package' because the latter is +;; tempermental. ELPA sources suffer downtime occasionally and often fail to +;; build packages when GNU Tar is unavailable (e.g. MacOS users start with BSD +;; tar). Known gnutls errors plague the current stable release of Emacs (26.x) +;; which bork TLS handshakes with ELPA repos (mainly gnu.elpa.org). See +;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=3434. +;; +;; What's worse, you can only get the latest version of packages through ELPA. +;; In an ecosystem that is constantly changing, this is more frustrating than +;; convenient. Straight (and Doom) can do rolling release, but it is opt-in. +;; +;; Interacting with this package management system is done through Doom's +;; bin/doom script. Find out more about it by running 'doom help' (I highly +;; recommend you add the script to your PATH). Here are some highlights: +;; +;; - `doom install`: a wizard that guides you through setting up Doom and your +;; private config for the first time. +;; - `doom sync`: your go-to command for making sure Doom is in optimal +;; condition. It ensures all unneeded packages are removed, all needed ones +;; are installed, and all metadata associated with them is generated. +;; - `doom upgrade`: upgrades Doom Emacs and your packages to the latest +;; versions. There's also 'bin/doom sync -u' for updating only your packages. +;; +;; How this works is: the system reads packages.el files located in each +;; activated module, your private config (`doom-user-dir'), and one in +;; `doom-core-dir'. These contain `package!' declarations that tell DOOM what +;; packages to install and where from. +;; +;; All that said, you can still use package.el's commands, but 'doom sync' will +;; purge ELPA packages. +;; +;;; Code: + +(setq straight-base-dir (file-truename doom-local-dir) + straight-repository-branch "develop" + ;; Since byte-code is rarely compatible across different versions of + ;; Emacs, it's best we build them in separate directories, per emacs + ;; version. + straight-build-dir (format "build-%s" emacs-version) + straight-cache-autoloads nil ; we already do this, and better. + ;; Doom doesn't encourage you to modify packages in place. Disabling this + ;; makes 'doom sync' instant (once everything set up), which is much nicer + ;; UX than the several seconds modification checks. + straight-check-for-modifications nil + ;; We handle package.el ourselves (and a little more comprehensively) + straight-enable-package-integration nil + ;; Before switching to straight, `doom-local-dir' would average out at + ;; around 100mb with half Doom's modules at ~230 packages. Afterwards, at + ;; around 1gb. With shallow cloning, that is reduced to ~400mb. This has + ;; no affect on packages that are pinned, however (run 'doom sync --gc' to + ;; compact those after-the-fact). Some packages break when shallow cloned + ;; (like magit and org), but we'll deal with that elsewhere. + straight-vc-git-default-clone-depth '(1 single-branch)) + +(with-eval-after-load 'straight + ;; HACK: Doom relies on deferred compilation, which spares the user 20-50min + ;; of compilation at install time, but subjects them to ~50% CPU activity + ;; when starting Emacs for the first time. To complete this, straight.el + ;; needs to be told not to do native-compilation, but it won't obey + ;; `straight-disable-native-compile'. + ;; + ;; It *will* obey `straight--native-comp-available', though. Trouble is: + ;; it's a constant; it resets itself when straight is loaded, so it must be + ;; changed afterwards. + (setq straight--native-comp-available nil) + ;; `let-alist' is built into Emacs 26 and onwards + (add-to-list 'straight-built-in-pseudo-packages 'let-alist)) + +(defadvice! doom--read-pinned-packages-a (fn &rest args) + "Read `:pin's in `doom-packages' on top of straight's lockfiles." + :around #'straight--lockfile-read-all + (append (apply fn args) ; lockfiles still take priority + (doom-package-pinned-alist))) + +;; HACK: This fixes an issue introduced in emacs-mirror/emacs@0d383b592c2f and +;; is present in >=29: Straight.el uses `loaddefs-generate' if it is +;; available, which activates `emacs-lisp-mode' to read autoloads files, but +;; does so without suppressing its hooks. Some packages (like overseer) add +;; hooks to `emacs-lisp-mode-hook' in their autoloads, and once triggered, +;; they will try to load their dependencies (like dash or pkg-info), causing +;; file errors. +;; REVIEW: Report this upstream. +(defadvice! doom--fix-loaddefs-generate--parse-file-a (fn &rest args) + :around #'loaddefs-generate--parse-file + (let (emacs-lisp-mode-hook) + (apply fn args))) + + +;; +;;; 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-straight--auto-options + '(("has diverged from" + . "^Reset [^ ]+ to ") + ("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\\|^Checkout \"")) + "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: `native-comp' only respects `native-comp-jit-compilation-deny-list' +;; when native-compiling packages in interactive sessions. It ignores the +;; variable when, say, straight is building packages. This advice forces it to +;; obey it, even when used by straight (but only in the CLI). +(defadvice! doom-straight--native--compile-async-skip-p (fn files &optional recursively load selector) + :around #'native-compile-async + (let (file-list) + (dolist (file-or-dir (ensure-list files)) + (cond ((file-directory-p file-or-dir) + (dolist (file (if recursively + (directory-files-recursively + file-or-dir comp-valid-source-re) + (directory-files file-or-dir + t comp-valid-source-re))) + (push file file-list))) + ((file-exists-p file-or-dir) + (push file-or-dir file-list)) + ((signal 'native-compiler-error + (list "Not a file nor directory" file-or-dir))))) + (funcall fn (seq-remove (lambda (file) + (seq-some (lambda (re) (string-match-p re file)) + native-comp-deferred-compilation-deny-list)) + file-list) + recursively load selector))) + +;; 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 noprompt?) + :around #'straight-are-you-sure + (or noprompt? + (if noninteractive + (y-or-n-p (format! "%s" (or prompt ""))) + (funcall fn 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--no-compute-prefixes-a (fn &rest args) + :around #'straight--build-autoloads + (let (autoload-compute-prefixes) + (apply fn args))) + +(defadvice! doom-straight--suppress-confirm-a (&rest _) + :before-until #'straight-are-you-sure + (and (bound-and-true-p doom-cli--context) + (doom-cli-context-suppress-prompts-p doom-cli--context))) + +(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 (bound-and-true-p async-in-child-emacs) + (error "Straight prompt: %s" prompt) + (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: Remove actions that don't work in noninteractive Emacs (like + ;; opening dired or magit). + (setq actions + (cl-remove-if (lambda (o) + (string-match-p "^\\(?:Magit\\|Dired\\)" (nth 1 o))) + actions)) + (if (doom-cli-context-suppress-prompts-p doom-cli--context) + (cl-loop 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"))) + (doom-cli--exit 1 doom-cli--context)) + (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 (concat "> " msg) :format t)))) + +(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))) + +;; If the repo failed to clone correctly (usually due to a connection failure), +;; straight proceeds as normal until a later call produces a garbage result +;; (typically, when it fails to fetch the remote branch of the empty directory). +;; This causes Straight to throw an otherwise cryptic type error when it tries +;; to sanitize the result for its log buffer. +;; +;; This error is a common source of user confusion and false positive bug +;; reports, so this advice catches them to regurgitates a more cogent +;; explanation. +(defadvice! doom-straight--throw-error-on-no-branch-a (fn &rest args) + :around #'straight--process-log + (letf! ((defun shell-quote-argument (&rest args) + (unless (car args) + (error "Package was not properly cloned due to a connection failure, please try again later")) + (apply shell-quote-argument args))) + (apply fn args))) + +(defadvice! doom-straight--regurgitate-empty-string-error-a (fn &rest args) + :around #'straight-vc-git-local-repo-name + (condition-case-unless-debug e + (apply fn args) + (wrong-type-argument + (if (eq (cadr e) 'stringp) + (error "Package was not properly cloned due to a connection failure, please try again later") + (signal (car e) (cdr e)))))) + +;; HACK: Fix an issue where straight wasn't byte-compiling some packages (or +;; some files in packages) due to missing (invisible) dependencies. +(defadvice! doom-straight--byte-compile-a (recipe) + "See https://github.com/radian-software/straight.el/pull/1132" + :override #'straight--build-compile + (let* ((pkg (plist-get recipe :package)) + (dir (straight--build-dir pkg)) + (emacs (concat invocation-directory invocation-name)) + (buffer straight-byte-compilation-buffer) + (deps + (let (tmp) + (dolist (dep (straight--flatten (straight-dependencies pkg)) tmp) + (let ((build-dir (straight--build-dir dep))) + (when (file-exists-p build-dir) + (push build-dir tmp)))))) + (print-circle nil) + (print-length nil) + (program + (format "%S" `(let ((default-directory ,(straight--build-dir)) + (lp load-path)) + (setq load-path (list default-directory)) + (normal-top-level-add-subdirs-to-load-path) + (setq load-path (append '(,dir) ',deps load-path lp)) + (byte-recompile-directory ,dir 0 'force)))) + (args (list "-Q" "--batch" "--eval" program))) + (when buffer + (with-current-buffer (get-buffer-create buffer) + (insert (format "\n$ %s %s \\\n %S\n" emacs + (string-join (butlast args) " ") + program)))) + (apply #'call-process `(,emacs nil ,buffer nil ,@args)))) + +(provide 'doom-straight) +;;; doom-packages.el ends here diff --git a/lisp/doom.el b/lisp/doom.el index eab4bf00d..7edf08d7b 100644 --- a/lisp/doom.el +++ b/lisp/doom.el @@ -70,7 +70,7 @@ ;; ;;; Code: -;; For `when-let' and `if-let' on versions of Emacs before they were autoloaded. +;; For `when-let*' and `if-let*' on versions of Emacs before they were autoloaded. (eval-when-compile (require 'subr-x)) (eval-and-compile ; Check version at both compile and runtime. @@ -100,7 +100,8 @@ " $ EMACS=\"snap run emacs\" " command " ...")) "\n\nAborting...") (concat "If you believe this error is a mistake, run 'doom doctor' on the command line\n" - "to diagnose common issues with your config and system.")))))) + "to diagnose common issues with your config and system."))))) + nil) ;; Doom needs to be synced/rebuilt if either Doom or Emacs has been ;; up/downgraded. This is because byte-code isn't backwards compatible, and many @@ -512,22 +513,13 @@ users).") ;; causes unnecessary redraws at startup which can impact startup time ;; drastically and cause flashes of white. It also pollutes the logs. I ;; suppress it here and load it myself, later, in a more controlled way - ;; (see `startup--load-user-init-file@undo-hacks'). + ;; (see `doom-initialize'). (put 'site-run-file 'initial-value site-run-file) (setq site-run-file nil) (define-advice startup--load-user-init-file (:around (fn &rest args) undo-hacks 95) "Undo Doom's startup optimizations to prep for the user's session." - (unwind-protect - (progn - (when (setq site-run-file (get 'site-run-file 'initial-value)) - (let ((inhibit-startup-screen inhibit-startup-screen)) - (letf! ((defun load-file (file) - (load file nil (not init-file-debug))) - (defun load (file &optional noerror _nomessage &rest args) - (apply load file noerror (not init-file-debug) args))) - (load site-run-file t)))) - (apply fn args)) + (unwind-protect (apply fn args) ;; Now it's safe to be verbose. (setq-default inhibit-message nil) ;; COMPAT: Once startup is sufficiently complete, undo our earlier @@ -545,70 +537,6 @@ users).") (setq command-line-x-option-alist nil)))) -;; -;;; `doom-context' - -(defvar doom-context '(t) - "A list of symbols identifying all active Doom execution contexts. - -This should never be directly changed, only let-bound, and should never be -empty. Each context describes what phase Doom is in, and may respond to. - -All valid contexts: - cli -- while executing a Doom CLI - compile -- while byte-compiling packages - eval -- during interactive evaluation of elisp - init -- while doom is formally starting up for the first time, after its - core libraries are loaded, but before $DOOMDIR is - modules -- while loading modules configuration files (but not packages) - sandbox -- This session was launched from Doom's sandbox - packages -- while a module's packages.el's file is being evaluated - reload -- while reloading doom with `doom/reload'") -(put 'doom-context 'valid-values '(cli compile eval init modules packages reload doctor sandbox)) -(put 'doom-context 'risky-local-variable t) - -(defun doom-context--assert (context) - (let ((valid (get 'doom-context 'valid-values))) - (unless (memq context valid) - (signal 'doom-context-error - (list context "Unrecognized context" valid))))) - -(defun doom-context-p (context) - "Return t if CONTEXT is active, nil otherwise. - -See `doom-context' for possible values for CONTEXT." - (if (memq context doom-context) t)) - -(defun doom-context-push (context) - "Add CONTEXT to `doom-context', if it isn't already. - -Return non-nil if successful. Throws an error if CONTEXT is invalid." - (unless (memq context doom-context) - (doom-context--assert context) - (doom-log ":context: +%s %s" context doom-context) - (push context doom-context))) - -(defun doom-context-pop (context &optional strict?) - "Remove CONTEXT from `doom-context'. - -Return non-nil if successful. If STRICT? is non-nil, throw an error if CONTEXT -wasn't active when this was called." - (if (not (doom-context-p context)) - (when strict? - (signal 'doom-context-error - (list doom-context "Attempt to pop missing context" context))) - (doom-log ":context: -%s %s" context doom-context) - (setq doom-context (delq context doom-context)))) - -(defmacro with-doom-context (contexts &rest body) - "Evaluate BODY with CONTEXTS added to `doom-context'." - (declare (indent 1)) - `(let ((doom-context doom-context)) - (dolist (context (ensure-list ,contexts)) - (doom-context-push context)) - ,@body)) - - ;; ;;; Reasonable, global defaults @@ -687,13 +615,17 @@ to `doom-cache-dir'/comp/ instead, so that Doom can safely clean it up as part of 'doom sync' or 'doom gc'." (let ((temporary-file-directory (expand-file-name "comp/" doom-profile-cache-dir))) (make-directory temporary-file-directory t) - (apply fn args)))) + (apply fn args))) + + (after! comp + ;; HACK Disable native-compilation for some troublesome packages + (mapc (doom-partial #'add-to-list 'native-comp-deferred-compilation-deny-list) + (list "/seq-tests\\.el\\'" + "/emacs-jupyter.*\\.el\\'" + "/evil-collection-vterm\\.el\\'" + "/vterm\\.el\\'" + "/with-editor\\.el\\'")))) -;;; Suppress package.el -;; Since Emacs 27, package initialization occurs before `user-init-file' is -;; loaded, but after `early-init-file'. Doom handles package initialization, so -;; we must prevent Emacs from doing it again. -(setq package-enable-at-startup nil) ;;; Reduce unnecessary/unactionable warnings/logs ;; Disable warnings from the legacy advice API. They aren't actionable or @@ -738,6 +670,35 @@ of 'doom sync' or 'doom gc'." "gnutls-cli -p %p %h")) +;;; Package managers +;; Since Emacs 27, package initialization occurs before `user-init-file' is +;; loaded, but after `early-init-file'. Doom handles package initialization, so +;; we must prevent Emacs from doing it again. +(setq package-enable-at-startup nil) + +;; Ensure that, if the user does want package.el, it is configured correctly. +;; You really shouldn't be using it, though... +(with-eval-after-load 'package + (setq package-user-dir (file-name-concat doom-local-dir "elpa/") + package-gnupghome-dir (expand-file-name "gpg" package-user-dir)) + (let ((s (if gnutls-verify-error "s" ""))) + (prependq! package-archives + ;; I omit Marmalade because its packages are manually submitted + ;; rather than pulled, and so often out of date. + `(("melpa" . ,(format "http%s://melpa.org/packages/" s)) + ("org" . ,(format "http%s://orgmode.org/elpa/" s))))) + + ;; Refresh package.el the first time you call `package-install', so it's still + ;; trivially usable. Remember to run 'doom sync' to purge them; they can + ;; conflict with packages installed via straight! + (add-transient-hook! 'package-install (package-refresh-contents))) + +;; DEPRECATED: Interactive sessions won't be able to interact with Straight (or +;; Elpaca) in the future, so this is temporary. +(with-eval-after-load 'straight + (require 'doom-straight)) + + ;; ;;; Custom hooks @@ -765,47 +726,155 @@ appropriately against `noninteractive' or the `cli' context." :group 'doom :type 'hook) +(defcustom doom-before-modules-init-hook nil + "Hooks run before module init.el files are loaded." + :group 'doom + :type 'hook) + +(defcustom doom-after-modules-init-hook nil + "Hooks run after module init.el files are loaded." + :group 'doom + :type 'hook) + +(defcustom doom-before-modules-config-hook nil + "Hooks run before module config.el files are loaded." + :group 'doom + :type 'hook) + +(defcustom doom-after-modules-config-hook nil + "Hooks run after module config.el files are loaded (but before the user's)." + :group 'doom + :type 'hook) + ;; -;;; Last minute initialization +;;; Initializers -(when (daemonp) - (message "Starting Doom Emacs in daemon mode...") - (unless doom-inhibit-log - (add-hook! 'doom-after-init-hook :depth 106 +(defun doom-initialize (&optional interactive?) + "Bootstrap the Doom session ahead." + (when (doom-context-push 'startup) + (when (daemonp) + (message "Starting Doom Emacs in daemon mode...") (unless doom-inhibit-log - (setq doom-inhibit-log (not (or noninteractive init-file-debug)))) - (message "Disabling verbose mode. Have fun!")) - (add-hook! 'kill-emacs-hook :depth 110 - (message "Killing Emacs. Sayonara!")))) + (add-hook! 'doom-after-init-hook :depth 106 + (unless doom-inhibit-log + (setq doom-inhibit-log (not (or noninteractive init-file-debug)))) + (message "Disabling verbose mode. Have fun!")) + (add-hook! 'kill-emacs-hook :depth 110 + (message "Killing Emacs. Sayonara!")))) + + (if interactive? + (when (doom-context-push 'emacs) + (add-hook 'doom-after-init-hook #'doom-load-packages-incrementally-h 100) + (add-hook 'doom-after-init-hook #'doom-display-benchmark-h 110) + (doom-run-hook-on 'doom-first-buffer-hook '(find-file-hook doom-switch-buffer-hook)) + (doom-run-hook-on 'doom-first-file-hook '(find-file-hook dired-initial-position-hook)) + (doom-run-hook-on 'doom-first-input-hook '(pre-command-hook)) + + ;; If the user's already opened something (e.g. with command-line + ;; arguments), then we should assume nothing about the user's + ;; intentions and simply treat this session as fully initialized. + (add-hook! 'doom-after-init-hook :depth 100 + (defun doom-run-first-hooks-if-files-open-h () + (when file-name-history + (doom-run-hooks 'doom-first-file-hook 'doom-first-buffer-hook)))) + + ;; These fire `MAJOR-MODE-local-vars-hook' hooks, which is a Doomism. + ;; See the `MODE-local-vars-hook' section above. + (add-hook 'after-change-major-mode-hook #'doom-run-local-var-hooks-h 100) + (add-hook 'hack-local-variables-hook #'doom-run-local-var-hooks-h) + + ;; This is the absolute latest a hook can run in Emacs' startup + ;; process. + (advice-add #'command-line-1 :after #'doom-finalize) + + (require 'doom-start) + (let ((init-file (doom-profile-init-file doom-profile))) + (or (doom-load init-file t) + (signal 'doom-nosync-error (list init-file))))) + + (when (doom-context-push 'cli) + ;; REVIEW: Remove later. The endpoints should be responsibile for + ;; ensuring they exist. For now, they exist to quell file errors. + (with-file-modes #o700 + (mapc (doom-rpartial #'make-directory 'parents) + (list doom-local-dir + doom-data-dir + doom-cache-dir + doom-state-dir))) + + (doom-require 'doom-lib 'debug) + (if init-file-debug (doom-debug-mode +1)) + + ;; Then load the rest of Doom's libs eagerly, since autoloads may not + ;; be generated/loaded yet. + (require 'seq) + (require 'map) + (mapc (doom-partial #'doom-require 'doom-lib) + '(process + system + git + plist + files + print + autoloads + profiles + modules + packages)) + + ;; Ensure the CLI framework is ready. + (require 'doom-cli) + (add-hook 'doom-cli-initialize-hook #'doom-finalize))) + + ;; HACK: We suppress loading of site files so they can be loaded manually, + ;; here. Why? To suppress the otherwise unavoidable output they commonly + ;; produce (like deprecation notices, file-loaded messages, and linter + ;; warnings). This output pollutes the output of doom's CLI (or scripts + ;; derived from it) with potentially confusing or alarming -- but always + ;; unimportant -- information to the user. + (let ((site-loader + (lambda () + (quiet!! + (unless interactive? + (require 'cl nil t)) ; "Package cl is deprecated" + (unless site-run-file + (when-let* ((site-file (get 'site-run-file 'initial-value))) + (let ((inhibit-startup-screen inhibit-startup-screen)) + (setq site-run-file site-file) + (load site-run-file t)))))))) + (if interactive? + (define-advice startup--load-user-init-file (:before (&rest _) load-site-files 100) + (funcall site-loader)) + (funcall site-loader))) + + ;; A last ditch opportunity to undo hacks or do extra configuration before + ;; the session is complicated by user config and packages. + (doom-run-hooks 'doom-before-init-hook) -(add-hook! 'doom-before-init-hook :depth -105 - (defun doom--begin-init-h () - "Begin the startup process." ;; HACK: Later versions of Emacs 30 emit warnings about missing ;; lexical-bindings directives at the top of loaded files. This is a good ;; thing, but it inundates users with unactionable warnings (from old ;; packages or internal subdirs.el files), which aren't useful. - (setq-default delayed-warnings-list - (assq-delete-all 'lexical-binding delayed-warnings-list)) - (when (doom-context-push 'init) - ;; HACK: Ensure OS checks are as fast as possible (given their ubiquity). - (setq features (cons :system (delq :system features))) - ;; Remember these variables' initial values, so we can safely reset them - ;; at a later time, or consult them without fear of contamination. - (dolist (var '(exec-path load-path process-environment)) - (put var 'initial-value (default-toplevel-value var)))))) + (cl-callf2 assq-delete-all 'lexical-binding delayed-warnings-list) -(add-hook! 'doom-after-init-hook :depth 105 - (defun doom--end-init-h () - "Set `doom-init-time'." - (when (doom-context-pop 'init) - (setq doom-init-time (float-time (time-subtract (current-time) before-init-time)))))) + ;; HACK: Ensure OS checks are as fast as possible (given their ubiquity). + (setq features (cons :system (delq :system features))) -(unless noninteractive - ;; This is the absolute latest a hook can run in Emacs' startup process. - (define-advice command-line-1 (:after (&rest _) run-after-init-hook) - (doom-run-hooks 'doom-after-init-hook))) + ;; Remember these variables' initial values, so we can safely reset them + ;; at a later time, or consult them without fear of contamination. + (dolist (var '(exec-path load-path process-environment)) + (put var 'initial-value (default-toplevel-value var))) + + t)) + +(defun doom-finalize (&rest _) + "Finalize the current Doom session, marking the end of its startup process. + +Triggers `doom-after-init-hook' and sets `doom-init-time.'" + (when (doom-context-pop 'startup) + (setq doom-init-time (float-time (time-subtract (current-time) before-init-time))) + (doom-run-hooks 'doom-after-init-hook) + t)) (provide 'doom) ;;; doom.el ends here diff --git a/lisp/lib/config.el b/lisp/lib/config.el index 6ed282826..c8fa29f24 100644 --- a/lisp/lib/config.el +++ b/lisp/lib/config.el @@ -104,7 +104,7 @@ Runs `doom-after-reload-hook' afterwards." (interactive) (mapc #'require (cdr doom-incremental-packages)) (doom--if-compile doom-reload-command - (with-doom-context '(reload modules) + (with-doom-context '(reload module) (doom-run-hooks 'doom-before-reload-hook) (doom-load (file-name-concat doom-user-dir doom-module-init-file) t) (with-demoted-errors "PRIVATE CONFIG ERROR: %s" @@ -127,7 +127,7 @@ remove orphaned ones. It also doesn't reload your private config. It is useful to only pull in changes performed by 'doom sync' on the command line." (interactive) - (require 'doom-profiles) + (doom-require 'doom-lib 'profiles) ;; TODO: Make this more robust (with-doom-context 'reload (dolist (file (mapcar #'car doom-profile-generators)) diff --git a/lisp/lib/debug.el b/lisp/lib/debug.el index 1238ecc7e..cc30606e6 100644 --- a/lisp/lib/debug.el +++ b/lisp/lib/debug.el @@ -233,7 +233,9 @@ Activate this advice with: "Returns diagnostic information about the current Emacs session in markdown, ready to be pasted in a bug report on github." (require 'vc-git) - (require 'doom-packages) + (doom-require 'doom-lib 'profiles) + (doom-require 'doom-lib 'modules) + (doom-require 'doom-lib 'packages) (let ((default-directory doom-emacs-dir)) (letf! ((defun sh (&rest args) (cdr (apply #'doom-call-process args))) (defun cat (file &optional limit) @@ -263,11 +265,7 @@ ready to be pasted in a bug report on github." (format "EMACSDIR=%s" (symlink-path doom-emacs-dir)) (format "EMACS=%s" (expand-file-name invocation-name invocation-directory))))) (doom . ,(list doom-version - (if doom-profile - (format "PROFILE=%s@%s" - (car doom-profile) - (cdr doom-profile)) - "PROFILE=_@0") + (format "PROFILE=%s" (doom-profile->id (doom-profile-key doom-profile t))) (if (file-exists-p! ".git" doom-emacs-dir) (sh "git" "log" "-1" "--format=%D %h %ci") "[no repo]") diff --git a/lisp/lib/help.el b/lisp/lib/help.el index 524523893..fd418e659 100644 --- a/lisp/lib/help.el +++ b/lisp/lib/help.el @@ -533,7 +533,6 @@ If prefix arg is present, refresh the cache." packages nil t nil nil (when guess (symbol-name guess)))))))) ;; TODO Refactor me. - (require 'doom-packages) (doom-initialize-packages) (help-setup-xref (list #'doom/help-packages package) (called-interactively-p 'interactive)) diff --git a/lisp/lib/modules.el b/lisp/lib/modules.el new file mode 100644 index 000000000..1a4145db6 --- /dev/null +++ b/lisp/lib/modules.el @@ -0,0 +1,229 @@ +;;; lib/modules.el -*- lexical-binding: t; -*- +;;; Commentary: +;;; Code: + +(defvar doom-modules nil + "A table of enabled modules and metadata. See `doom-modules-initialize'.") + +(define-obsolete-variable-alias 'doom-modules-dirs 'doom-module-load-path "3.0.0") +(defvar doom-module-load-path + (list (file-name-concat doom-user-dir "modules") + (file-name-concat doom-emacs-dir "modules")) + "A list of paths where Doom should search for modules. + +Order determines priority (from highest to lowest). + +Each entry is a string; an absolute path to the root directory of a module tree. +In other words, they should contain a two-level nested directory structure, +where the module's group and name was deduced from the first and second level of +directories. For example: if $DOOMDIR/modules/ is an entry, a +$DOOMDIR/modules/lang/ruby/ directory represents a ':lang ruby' module.") + +;; DEPRECATED: Remove in v3, as it will be handled in the CLI +(make-obsolete-variable 'doom-obsolete-modules nil "3.0.0") +(defconst doom-obsolete-modules + '((:feature (version-control (:emacs vc) (:ui vc-gutter)) + (spellcheck (:checkers spell)) + (syntax-checker (:checkers syntax)) + (evil (:editor evil)) + (snippets (:editor snippets)) + (file-templates (:editor file-templates)) + (workspaces (:ui workspaces)) + (eval (:tools eval)) + (lookup (:tools lookup)) + (debugger (:tools debugger))) + (:tools (rotate-text (:editor rotate-text)) + (vterm (:term vterm)) + (password-store (:tools pass)) + (flycheck (:checkers syntax)) + (flyspell (:checkers spell)) + (macos (:os macos))) + (:emacs (electric-indent (:emacs electric)) + (hideshow (:editor fold)) + (eshell (:term eshell)) + (term (:term term))) + (:ui (doom-modeline (:ui modeline)) + (fci (:ui fill-column)) + (evil-goggles (:ui ophints)) + (tabbar (:ui tabs)) + (pretty-code (:ui ligatures))) + (:app (email (:email mu4e)) + (notmuch (:email notmuch))) + (:lang (perl (:lang raku)))) + "A tree alist that maps deprecated modules to their replacement(s). + +Each entry is a three-level tree. For example: + + (:feature (version-control (:emacs vc) (:ui vc-gutter)) + (spellcheck (:checkers spell)) + (syntax-checker (:tools flycheck))) + +This marks :feature version-control, :feature spellcheck and :feature +syntax-checker modules obsolete. e.g. If :feature version-control is found in +your `doom!' block, a warning is emitted before replacing it with :emacs vc and +:ui vc-gutter.") + +(make-obsolete-variable 'doom-inhibit-module-warnings nil "3.0.0") +(defvar doom-inhibit-module-warnings (not noninteractive) + "If non-nil, don't emit deprecated or missing module warnings at startup.") + +;;; Module file variables +(defvar doom-module-init-file "init.el" + "The filename for module early initialization config files. + +Init files are loaded early, just after Doom core, and before modules' config +files. They are always loaded, even in non-interactive sessions, and before +`doom-before-modules-init-hook'. Related to `doom-module-config-file'.") + +(defvar doom-module-config-file "config.el" + "The filename for module configuration files. + +Config files are loaded later, and almost always in interactive sessions. These +run before `doom-after-modules-config-hook' and after `doom-module-init-file'.") + +(defvar doom-module-packages-file "packages.el" + "The filename for the package configuration file. + +Package files are read whenever Doom's package manager wants a manifest of all +desired packages. They are rarely read in interactive sessions (unless the user +uses a straight or package.el command directly).") + + +;; +;;; API + +;;;###autoload +(defun doom-modules-initialize (&optional force?) + "Initializes module metadata." + (when (or (null doom-modules) force?) + (setq doom-modules (make-hash-table :test 'equal)) + ;; Register Doom's two virtual module categories, representing Doom's core + ;; and the user's config; which are always enabled. + (doom-module--put '(:doom . nil) :path doom-core-dir :depth -110) + (doom-module--put '(:user . nil) :path doom-user-dir :depth '(-105 . 105)) + ;; DEPRECATED: I intend to phase out our internal usage of `use-package' and + ;; move it to a :config use-package module. The macro is far too complex + ;; and magical for our needs, but until this move is done, ':config + ;; use-package' will remain a hardcoded module for backwards + ;; compatibility. + (doom-module--put '(:config . use-package) + :path (doom-module-locate-path '(:config . use-package)) + :depth -111) + ;; Load $DOOMDIR/init.el, where the user's `doom!' lives, which will inform + ;; us of all desired modules. + (doom-load (file-name-concat doom-user-dir doom-module-init-file) + 'noerror))) + +(cl-defun doom-module--put ((group . name) &rest plist) + "Enable GROUP NAME and associate PLIST with it. + +This enables the target module, where GROUP is a keyword, NAME is a symbol, and +PLIST is a property list accepting none, any, or all of the following +properties: + + :group KEYWORD + Indicating the group this module is in. This doesn't have to match GROUP, as + it could indicate a module alias. + :name SYMBOL + Indicating the name of this module. This doesn't have to match NAME, as it + could indicate a module alias. + :path STRING + Path to the directory where this module lives. + :depth INT|(INITDEPTH . CONFIGDEPTH) + Determines module load order. If a cons cell, INITDEPTH determines the load + order of the module's init.el, while CONFIGDEPTH determines the same for all + other config files (config.el, packages.el, doctor.el, etc). + :flags (SYMBOL...) + A list of activated flags for this module. Will be collapsed into + pre-existing flags for the module. + :features (SYMBOL...) + A list of active features, determined from the module's metadata. Will be + collapsed into any pre-existing features for the module. NOT IMPLEMENTED + YET. + +\(fn (GROUP . NAME) &key GROUP NAME PATH DEPTH FLAGS FEATURES)" + (let ((module + (make-doom-module + :index (hash-table-count doom-modules) + :group (or (plist-get plist :group) group) + :name (or (plist-get plist :name) name) + :path (plist-get plist :path) + :flags (plist-get plist :flags) + :features () ; TODO + :depth + (if (not (plist-member plist :depth)) + '(0 . 0) + (let ((depth (plist-get plist :depth))) + (cl-check-type depth (or integer cons)) + (cond ((integerp depth) (cons depth depth)) + ((consp depth) (cons (or (car depth) 0) + (or (cdr depth) 0))) + ((error "Invalid DEPTH value: %S" depth)))))))) + (doom-log 2 "module-put: %s" module) + (prog1 (puthash (cons group name) module doom-modules) + ;; PERF: Doom caches module index, flags, and features in symbol plists + ;; for fast lookups in `modulep!' and elsewhere. plists are lighter and + ;; faster than hash tables for datasets this size, and this information + ;; is looked up *very* often. + (put group name (doom-module->context module))))) + +(defun doom-module-mplist-map (fn mplist) + "Apply FN to each module in MPLIST." + (let ((mplist (copy-sequence mplist)) + (inhibit-message doom-inhibit-module-warnings) + obsolete + results + group m) + (while mplist + (setq m (pop mplist)) + (cond ((keywordp m) + (setq group m + obsolete (assq m doom-obsolete-modules))) + ((null group) + (error "No module group specified for %s" m)) + ((and (listp m) (keywordp (car m))) + (pcase (car m) + (:cond + (cl-loop for (cond . mods) in (cdr m) + if (eval cond t) + return (prependq! mplist mods))) + (:if (if (eval (cadr m) t) + (push (caddr m) mplist) + (prependq! mplist (cdddr m)))) + (test (if (xor (eval (cadr m) t) + (eq test :unless)) + (prependq! mplist (cddr m)))))) + ((catch 'doom-modules + (let* ((module (if (listp m) (car m) m)) + (flags (if (listp m) (cdr m)))) + (when-let (new (assq module obsolete)) + (let ((newkeys (cdr new))) + (if (null newkeys) + (print! (warn "%s module was removed")) + (if (cdr newkeys) + (print! (warn "%s module was removed and split into the %s modules") + (list group module) + (mapconcat #'prin1-to-string newkeys ", ")) + (print! (warn "%s module was moved to %s") + (list group module) + (car newkeys))) + (push group mplist) + (dolist (key newkeys) + (push (if flags + (nconc (cdr key) flags) + (cdr key)) + mplist) + (push (car key) mplist)) + (throw 'doom-modules t)))) + (doom-log "module: %s %s %s -> %s" group module (or flags "") + (doom-module-locate-path (cons group module))) + (push (funcall fn (cons group module) + :flags (if (listp m) (cdr m)) + :path (doom-module-locate-path (cons group module))) + results)))))) + (when noninteractive + (setq doom-inhibit-module-warnings t)) + (nreverse results))) + +(provide 'doom-lib '(modules)) +;;; modules.el ends here diff --git a/lisp/lib/packages.el b/lisp/lib/packages.el index 607154820..54ec1e791 100644 --- a/lisp/lib/packages.el +++ b/lisp/lib/packages.el @@ -1,4 +1,459 @@ ;;; lisp/lib/packages.el -*- lexical-binding: t; -*- +;;; Commentary: +;; +;; Emacs package management is opinionated, and so is Doom. Doom uses `straight' +;; to create a declarative, lazy-loaded, and (nominally) reproducible package +;; management system. We use `straight' over `package' because the latter is +;; tempermental. ELPA sources suffer downtime occasionally and often fail to +;; build packages when GNU Tar is unavailable (e.g. MacOS users start with BSD +;; tar). Known gnutls errors plague the current stable release of Emacs (26.x) +;; which bork TLS handshakes with ELPA repos (mainly gnu.elpa.org). See +;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=3434. +;; +;; What's worse, you can only get the latest version of packages through ELPA. +;; In an ecosystem that is constantly changing, this is more frustrating than +;; convenient. Straight (and Doom) can do rolling release, but it is opt-in. +;; +;; Interacting with this package management system is done through Doom's +;; bin/doom script. Find out more about it by running 'doom help' (I highly +;; recommend you add the script to your PATH). Here are some highlights: +;; +;; - `doom install`: a wizard that guides you through setting up Doom and your +;; private config for the first time. +;; - `doom sync`: your go-to command for making sure Doom is in optimal +;; condition. It ensures all unneeded packages are removed, all needed ones +;; are installed, and all metadata associated with them is generated. +;; - `doom upgrade`: upgrades Doom Emacs and your packages to the latest +;; versions. There's also 'bin/doom sync -u' for updating only your packages. +;; +;; How this works is: the system reads packages.el files located in each +;; activated module, your private config (`doom-user-dir'), and one in +;; `doom-core-dir'. These contain `package!' declarations that tell DOOM what +;; packages to install and where from. +;; +;; All that said, you can still use package.el's commands, but 'doom sync' will +;; purge ELPA packages. +;; +;;; Code: + +;; DEPRECATED: Will be stored in the local profile in v3.0 +(defvar doom-packages () + "A list of enabled packages. Each element is a sublist, whose CAR is the +package's name as a symbol, and whose CDR is the plist supplied to its +`package!' declaration. Set by `doom-initialize-packages'.") + +;; DEPRECATED: Will be stored in the local profile in v3.0 +(defvar doom-disabled-packages () + "A list of packages that should be ignored by `use-package!' and `after!'.") + + +;; +;;; Package management API + +(defun doom--ensure-straight (recipe pin) + (letenv! (("GIT_CONFIG" nil) + ("GIT_CONFIG_NOSYSTEM" "1") + ("GIT_CONFIG_GLOBAL" (or (getenv "DOOMGITCONFIG") + "/dev/null"))) + (let ((repo-dir (doom-path straight-base-dir "straight/repos/straight.el")) + (repo-url (concat "http" (if gnutls-verify-error "s") + "://github.com/" + (or (plist-get recipe :repo) "radian-software/straight.el"))) + (branch (or (plist-get recipe :branch) straight-repository-branch)) + (call (if init-file-debug + (lambda (&rest args) + (print! "%s" (cdr (apply #'doom-call-process args)))) + (lambda (&rest args) + (apply #'doom-call-process args))))) + (unless (file-directory-p repo-dir) + (save-match-data + (unless (executable-find "git") + (user-error "Git isn't present on your system. Cannot proceed.")) + (let* ((version (cdr (doom-call-process "git" "version"))) + (version + (and (string-match "\\_<[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)\\_>" version) + (match-string 0 version)))) + (if version + (when (version< version "2.23") + (user-error "Git %s detected! Doom requires git 2.23 or newer!" + version))))) + (print! (start "Installing straight...")) + (print-group! + (cl-destructuring-bind (depth . options) + (ensure-list straight-vc-git-default-clone-depth) + (let ((branch-switch (if (memq 'single-branch options) + "--single-branch" + "--no-single-branch"))) + (cond + ((eq 'full depth) + (funcall call "git" "clone" "--origin" "origin" + branch-switch repo-url repo-dir)) + ((integerp depth) + (if (null pin) + (progn + (when (file-directory-p repo-dir) + (delete-directory repo-dir 'recursive)) + (funcall call "git" "clone" "--origin" "origin" repo-url + "--no-checkout" repo-dir + "--depth" (number-to-string depth) + branch-switch + "--no-tags" + "--branch" straight-repository-branch)) + (make-directory repo-dir 'recursive) + (let ((default-directory repo-dir)) + (funcall call "git" "init") + (funcall call "git" "branch" "-m" straight-repository-branch) + (funcall call "git" "remote" "add" "origin" repo-url + "--master" straight-repository-branch) + (funcall call "git" "fetch" "origin" pin + "--depth" (number-to-string depth) + "--no-tags") + (funcall call "git" "reset" "--hard" pin))))))))) + (require 'straight (concat repo-dir "/straight.el")) + (doom-log "Initializing recipes") + (mapc #'straight-use-recipes + '((org-elpa :local-repo nil) + (melpa :type git :host github + :repo "melpa/melpa" + :build nil) + (nongnu-elpa :type git + :repo "https://git.savannah.gnu.org/git/emacs/nongnu.git" + :local-repo "nongnu-elpa" + :build nil) + (gnu-elpa-mirror :type git :host github + :repo "emacs-straight/gnu-elpa-mirror" + :build nil) + (el-get :type git :host github + :repo "dimitri/el-get" + :build nil) + (emacsmirror-mirror :type git :host github + :repo "emacs-straight/emacsmirror-mirror" + :build nil)))))) + +(defun doom--ensure-core-packages (packages) + (doom-log "Installing core packages") + (dolist (package packages) + (let* ((name (car package)) + (repo (symbol-name name))) + (when-let (recipe (plist-get (cdr package) :recipe)) + (straight-override-recipe (cons name recipe)) + (when-let (local-repo (plist-get recipe :local-repo)) + (setq repo local-repo))) + (print-group! + ;; Only clone the package, don't build them. Straight hasn't been fully + ;; configured by this point. + (straight-use-package name nil t)) + ;; In case the package hasn't been built yet. + (or (member (directory-file-name (straight--build-dir (symbol-name name))) + load-path) + (add-to-list 'load-path (directory-file-name (straight--repos-dir repo))))))) + +;;;###autoload +(defun doom-initialize-core-packages (&optional force-p) + "Ensure `straight' is installed and was compiled with this version of Emacs." + (require 'doom-straight) + (when (or force-p (null (bound-and-true-p straight-recipe-repositories))) + (doom-log "Initializing straight") + (let ((packages (doom-package-list '((:doom))))) + (cl-destructuring-bind (&key recipe pin &allow-other-keys) + (alist-get 'straight packages) + (doom--ensure-straight recipe pin)) + (doom--ensure-core-packages + (seq-filter (fn! (eq (plist-get (cdr %) :type) 'core)) + packages))))) + +;;;###autoload +(defun doom-initialize-packages (&optional force-p) + "Process all packages, essential and otherwise, if they haven't already been. + +If FORCE-P is non-nil, do it anyway. + +This ensures `doom-packages' is populated and `straight' recipes are properly +processed." + (require 'doom-straight) + (doom-initialize-core-packages force-p) + (when (or force-p (not (bound-and-true-p package--initialized))) + (doom-log "Initializing package.el") + (require 'package) + (package-initialize) + (unless package--initialized + (error "Failed to initialize package.el"))) + (when (or force-p (null doom-packages)) + (doom-log "Initializing straight.el") + (setq doom-disabled-packages nil + doom-packages (doom-package-list)) + (let (packages) + (dolist (package doom-packages) + (cl-destructuring-bind + (name &key recipe disable ignore &allow-other-keys) package + (if ignore + (straight-override-recipe (cons name '(:type built-in))) + (if disable + (cl-pushnew name doom-disabled-packages) + (when recipe + (straight-override-recipe (cons name recipe))) + (appendq! packages (cons name (straight--get-dependencies name))))))) + (dolist (package (cl-delete-duplicates packages :test #'equal)) + (straight-register-package package) + (let ((name (symbol-name package))) + (add-to-list 'load-path (directory-file-name (straight--build-dir name))) + (straight--load-package-autoloads name)))))) + +;;;###autoload +(defun doom-package-get (package &optional prop nil-value) + "Returns PACKAGE's `package!' recipe from `doom-packages'." + (let ((plist (cdr (assq package doom-packages)))) + (if prop + (if (plist-member plist prop) + (plist-get plist prop) + nil-value) + plist))) + +;;;###autoload +(defun doom-package-set (package prop value) + "Set PROPERTY in PACKAGE's recipe to VALUE." + (setf (alist-get package doom-packages) + (plist-put (alist-get package doom-packages) + prop value))) + +;;;###autoload +(defun doom-package-recipe (package &optional prop nil-value) + "Returns the `straight' recipe PACKAGE was registered with." + (let* ((recipe (straight-recipes-retrieve package)) + (plist (doom-plist-merge + (plist-get (alist-get package doom-packages) :recipe) + (cdr (if (memq (car recipe) '(quote \`)) + (eval recipe t) + recipe))))) + (if prop + (if (plist-member plist prop) + (plist-get plist prop) + nil-value) + plist))) + +;;;###autoload +(defun doom-package-recipe-repo (package) + "Resolve and return PACKAGE's (symbol) local-repo property." + (if-let* ((recipe (copy-sequence (doom-package-recipe package))) + (recipe (if (and (not (plist-member recipe :type)) + (memq (plist-get recipe :host) '(github gitlab bitbucket))) + (plist-put recipe :type 'git) + recipe)) + (repo (if-let (local-repo (plist-get recipe :local-repo)) + (directory-file-name local-repo) + (ignore-errors (straight-vc-local-repo-name recipe))))) + repo + (symbol-name package))) + +;;;###autoload +(defun doom-package-build-recipe (package &optional prop nil-value) + "Returns the `straight' recipe PACKAGE was installed with." + (let ((plist (nth 2 (gethash (symbol-name package) straight--build-cache)))) + (if prop + (if (plist-member plist prop) + (plist-get plist prop) + nil-value) + plist))) + +;;;###autoload +(defun doom-package-dependencies (package &optional recursive noerror) + "Return a list of dependencies for a package. + +If RECURSIVE is `tree', return a tree of dependencies. +If RECURSIVE is nil, only return PACKAGE's immediate dependencies. +If NOERROR, return nil in case of error." + (cl-check-type package symbol) + (let ((deps (straight-dependencies (symbol-name package)))) + (pcase recursive + (`tree deps) + (`t (flatten-list deps)) + (`nil (cl-remove-if #'listp deps))))) + +;;;###autoload +(defun doom-package-depending-on (package &optional noerror) + "Return a list of packages that depend on PACKAGE. + +If PACKAGE (a symbol) isn't installed, throw an error, unless NOERROR is +non-nil." + (cl-check-type package symbol) + ;; can't get dependencies for built-in packages + (unless (or (doom-package-build-recipe package) + noerror) + (error "Couldn't find %s, is it installed?" package)) + (straight-dependents (symbol-name package))) + +;;; Predicate functions +;;;###autoload +(defun doom-package-built-in-p (package) + "Return non-nil if PACKAGE (a symbol) is built-in." + (eq (doom-package-build-recipe package :type) + 'built-in)) + +;;;###autoload +(defun doom-package-installed-p (package) + "Return non-nil if PACKAGE (a symbol) is installed." + (file-directory-p (straight--build-dir (symbol-name package)))) + +;;;###autoload +(defun doom-package-is-type-p (package type) + "TODO" + (memq type (ensure-list (doom-package-get package :type)))) + +;;;###autoload +(defun doom-package-in-module-p (package category &optional module) + "Return non-nil if PACKAGE was installed by the user's private config." + (when-let (modules (doom-package-get package :modules)) + (or (and (not module) (assq :user modules)) + (member (cons category module) modules)))) + +;;;###autoload +(defun doom-package-backend (package) + "Return 'straight, 'builtin, 'elpa or 'other, depending on how PACKAGE is +installed." + (cond ((gethash (symbol-name package) straight--build-cache) + 'straight) + ((or (doom-package-built-in-p package) + (assq package package--builtins)) + 'builtin) + ((assq package package-alist) + 'elpa) + ((locate-library (symbol-name package)) + 'other))) + + +;;; Package getters +(defun doom-packages--read (file &optional noeval noerror) + (condition-case-unless-debug e + (with-temp-buffer ; prevent buffer-local state from propagating + (if (not noeval) + (load file noerror 'nomessage 'nosuffix) + (when (file-exists-p file) + (insert-file-contents file) + (with-syntax-table emacs-lisp-mode-syntax-table + ;; Scrape `package!' blocks from FILE for a comprehensive listing of + ;; packages used by this module. + (while (search-forward "(package!" nil t) + (let ((ppss (save-excursion (syntax-ppss)))) + ;; Don't collect packages in comments or strings + (unless (or (nth 3 ppss) + (nth 4 ppss)) + (goto-char (match-beginning 0)) + (cl-destructuring-bind (_ name . plist) + (read (current-buffer)) + (push (cons + name (plist-put + plist :modules + (list (doom-module-context-key doom-module-context)))) + doom-packages))))))))) + (user-error + (user-error (error-message-string e))) + (error + (signal 'doom-package-error + (list (doom-module-context-key doom-module-context) + file e))))) + +;;;###autoload +(defun doom-package-list (&optional module-list) + "Retrieve a list of explicitly declared packages from MODULE-LIST. + +If MODULE-LIST is omitted, read enabled module list in configdepth order (see +`doom-module-set'). Otherwise, MODULE-LIST may be any symbol (or t) to mean read +all modules in `doom-modules-dir', including :doom and :user. MODULE-LIST may +also be a list of module keys." + (let ((module-list (cond ((null module-list) (doom-module-list)) + ((symbolp module-list) (doom-module-list 'all)) + (module-list))) + (packages-file doom-module-packages-file) + doom-disabled-packages + doom-packages) + (letf! (defun read-packages (key) + (with-doom-module key + (when-let (file (doom-module-locate-path + key doom-module-packages-file)) + (doom-packages--read file nil 'noerror)))) + (with-doom-context 'package + (let ((user? (assq :user module-list))) + (when user? + ;; We load the private packages file twice to populate + ;; `doom-disabled-packages' disabled packages are seen ASAP... + (let (doom-packages) + (read-packages (cons :user nil)))) + (mapc #'read-packages module-list) + ;; ...Then again to ensure privately overriden packages are properly + ;; overwritten. + (if user? (read-packages (cons :user nil))) + (nreverse doom-packages)))))) + +;;;###autoload +(defun doom-package-pinned-alist () + "Return an alist mapping package names (strings) to pinned commits (strings)." + (let (alist) + (dolist (package doom-packages alist) + (cl-destructuring-bind (name &key disable ignore pin unpin &allow-other-keys) + package + (when (and (not ignore) + (not disable) + (or pin unpin)) + (setf (alist-get (file-name-nondirectory (doom-package-recipe-repo name)) + alist nil 'remove #'equal) + (unless unpin pin))))))) + +;;;###autoload +(defun doom-package-recipe-alist () + "Return straight recipes for non-builtin packages with a local-repo." + (let (recipes) + (dolist (recipe (hash-table-values straight--recipe-cache)) + (cl-destructuring-bind (&key local-repo type &allow-other-keys) + recipe + (unless (or (null local-repo) + (eq type 'built-in)) + (push recipe recipes)))) + (nreverse recipes))) + +;;;###autoload +(defun doom-package-homepage (package) + "return the url to package's homepage (usually a repo)." + (doom-initialize-packages) + (or (get package 'homepage) + (put package 'homepage + (cond ((when-let (location (locate-library (symbol-name package))) + (with-temp-buffer + (if (string-match-p "\\.gz$" location) + (jka-compr-insert-file-contents location) + (insert-file-contents (concat (file-name-sans-extension location) ".el") + nil 0 4096)) + (let ((case-fold-search t)) + (when (re-search-forward " \\(?:url\\|homepage\\|website\\): \\(http[^\n]+\\)\n" nil t) + (match-string-no-properties 1)))))) + ((when-let ((recipe (straight-recipes-retrieve package))) + (straight--with-plist (straight--convert-recipe recipe) + (host repo) + (pcase host + (`github (format "https://github.com/%s" repo)) + (`gitlab (format "https://gitlab.com/%s" repo)) + (`bitbucket (format "https://bitbucket.com/%s" (plist-get plist :repo))) + (`git repo) + (_ nil))))) + ((or package-archive-contents + (progn (package-refresh-contents) + package-archive-contents)) + (pcase (ignore-errors (package-desc-archive (cadr (assq package package-archive-contents)))) + (`nil nil) + ("org" "https://orgmode.org") + ((or "melpa" "melpa-mirror") + (format "https://melpa.org/#/%s" package)) + ("gnu" + (format "https://elpa.gnu.org/packages/%s.html" package)) + (archive + (if-let (src (cdr (assoc package package-archives))) + (format "%s" src) + (user-error "%s isn't installed through any known source (%s)" + package archive))))) + ((user-error "Can't get homepage for %S package" package)))))) + + +;; +;;; Commands ;;;###autoload (defun doom/reload-packages () @@ -9,10 +464,6 @@ (doom-initialize-packages t) (message "Reloading packages...DONE")) - -;; -;;; Bump commands - (defun doom--package-merge-recipes (package plist) (require 'straight) (doom-plist-merge @@ -49,7 +500,7 @@ (or buffer-file-name (bound-and-true-p org-src-source-file-name))) (package - (with-doom-context 'packages + (with-doom-context 'package (with-doom-module (doom-module-from-path buffer-file-name) (eval (sexp-at-point) t))))) (list :beg beg @@ -191,10 +642,6 @@ each package." (when (doom-module-locate-path module doom-module-packages-file) (doom/bump-module (car module) (cdr module)))))) - -;; -;;; Bump commits - ;;;###autoload (defun doom/bumpify-diff (&optional interactive) "Copy user/repo@hash -> user/repo@hash's of changed packages to clipboard. @@ -273,50 +720,5 @@ Must be run from a magit diff buffer." (magit-commit-create (list "-e" "-m" (doom/bumpify-diff)))) - -;; -;;; Package metadata - -;;;###autoload -(defun doom-package-homepage (package) - "Return the url to PACKAGE's homepage (usually a repo)." - (doom-initialize-packages) - (or (get package 'homepage) - (put package 'homepage - (cond ((when-let (location (locate-library (symbol-name package))) - (with-temp-buffer - (if (string-match-p "\\.gz$" location) - (jka-compr-insert-file-contents location) - (insert-file-contents (concat (file-name-sans-extension location) ".el") - nil 0 4096)) - (let ((case-fold-search t)) - (when (re-search-forward " \\(?:URL\\|homepage\\|Website\\): \\(http[^\n]+\\)\n" nil t) - (match-string-no-properties 1)))))) - ((when-let ((recipe (straight-recipes-retrieve package))) - (straight--with-plist (straight--convert-recipe recipe) - (host repo) - (pcase host - (`github (format "https://github.com/%s" repo)) - (`gitlab (format "https://gitlab.com/%s" repo)) - (`bitbucket (format "https://bitbucket.com/%s" (plist-get plist :repo))) - (`git repo) - (_ nil))))) - ((or package-archive-contents - (progn (package-refresh-contents) - package-archive-contents)) - (pcase (ignore-errors (package-desc-archive (cadr (assq package package-archive-contents)))) - (`nil nil) - ("org" "https://orgmode.org") - ((or "melpa" "melpa-mirror") - (format "https://melpa.org/#/%s" package)) - ("gnu" - (format "https://elpa.gnu.org/packages/%s.html" package)) - (archive - (if-let (src (cdr (assoc package package-archives))) - (format "%s" src) - (user-error "%S isn't installed through any known source (%s)" - package archive))))) - ((user-error "Can't get homepage for %S package" package)))))) - (provide 'doom-lib '(packages)) ;;; packages.el ends here diff --git a/lisp/doom-profiles.el b/lisp/lib/profiles.el similarity index 54% rename from lisp/doom-profiles.el rename to lisp/lib/profiles.el index 4e3e8816d..e45410bce 100644 --- a/lisp/doom-profiles.el +++ b/lisp/lib/profiles.el @@ -1,11 +1,6 @@ -;;; lisp/doom-profiles.el -*- lexical-binding: t; -*- +;;; lisp/lib/profiles.el -*- lexical-binding: t; -*- ;;; Commentary: ;;; Code: -(eval-when-compile (require 'doom)) ; be silent, o'byte-compiler - - -;; -;;; Variables ;;; File/directory variables (defvar doom-profiles-generated-dir doom-data-dir @@ -46,29 +41,28 @@ list of paths or profile config files (semi-colon delimited on Windows).") Can be changed externally by setting $DOOMPROFILELOADFILE.") -(defvar doom-profile-init-file-name (format "init.%d.el" emacs-major-version) +(defvar doom-profile-env-file-name "init.env.el" "TODO") (defvar doom-profile-init-dir-name (format "init.%d.d" emacs-major-version) "The subdirectory of `doom-profile-dir'") -(defvar doom-profiles-config-file-name ".doomprofile" +(defvar doom-profile-rcfile ".doomprofile" "TODO") ;;; Profile storage variables (defvar doom-profile-generators - '(("05-init-vars.auto.el" . doom-profile--generate-init-vars) + '(("05-vars.auto.el" . doom-profile--generate-init-vars) ("80-loaddefs.auto.el" . doom-profile--generate-doom-autoloads) ("90-loaddefs-packages.auto.el" . doom-profile--generate-package-autoloads) - ("95-load-modules.auto.el" . doom-profile--generate-load-modules)) + ("95-modules.auto.el" . doom-profile--generate-load-modules)) "An alist mapping file names to generator functions. The file will be generated in `doom-profile-dir'/`doom-profile-init-dir-name', -and later combined into `doom-profile-dir'/`doom-profile-init-file-name' in -lexicographical order. These partials are left behind in case the use wants to -load them directly (for whatever use), or for commands to use (e.g. -`doom/reload-autoloads' loads any file with a NN-loaddefs[-.] prefix to -accomplish its namesake). +and later combined into `doom-profile-dir' in lexicographical order. These +partials are left behind in case the use wants to load them directly (for +whatever use), or for commands to use (e.g. `doom/reload-autoloads' loads any +file with a NN-loaddefs[-.] prefix to accomplish its namesake). Files with an .auto.el suffix will be automatically deleted whenever the profile is regenerated. Users (or Doom CLIs, like `doom env') may add their own @@ -78,7 +72,11 @@ run.") (defvar doom--profiles ()) -(defconst doom-profile-default (cons "_" "0")) + +;; +;;; Bootstrappers + +;; (defun doom-profile-initialize (profile &optional project-dir nocache?)) ;; @@ -92,13 +90,14 @@ run.") (defun doom-profiles-read (&rest paths) "TODO" - (let (profiles) + (let ((key (doom-profile-key t)) + profiles) (dolist (path (delq nil (flatten-list paths))) (cond ((file-directory-p path) (setq path (file-truename path)) (dolist (subdir (doom-files-in path :depth 0 :match "/[^.][^/]+$" :type 'dirs :map #'file-name-base)) - (if (equal subdir (car doom-profile-default)) + (if (equal subdir (car key)) (signal 'doom-profile-error (list (file-name-concat path subdir) "Implicit profile has invalid name")) (unless (string-prefix-p "_" subdir) (cl-pushnew @@ -108,7 +107,7 @@ run.") `(,val) `(,(abbreviate-file-name path) ,val)))) (cons `(user-emacs-directory :path ,@val) - (if-let (profile-file (file-exists-p! doom-profiles-config-file-name path)) + (if-let (profile-file (file-exists-p! doom-profile-rcfile path)) (car (doom-file-read profile-file :by 'read*)) (when (file-exists-p (doom-path path subdir "lisp/doom.el")) '((doom-user-dir :path ,@val))))))) @@ -117,7 +116,7 @@ run.") :key #'car))))) ((file-exists-p path) (dolist (profile (car (doom-file-read path :by 'read*))) - (if (eq (symbol-name (car profile)) (car doom-profile-default)) + (if (eq (symbol-name (car profile)) (car key)) (signal 'doom-profile-error (list path "Profile has invalid name: _")) (unless (string-prefix-p "_" (symbol-name (car profile))) (cl-pushnew profile profiles @@ -125,6 +124,95 @@ run.") :key #'car))))))) (nreverse profiles))) +(defun doom-profiles-write-load-file (profiles &optional file) + "Generate a profile bootstrapper for Doom to load at startup." + (unless file + (setq file doom-profile-load-file)) + (doom-file-write + file `(";; -*- lexical-binding: t; tab-width: 8; -*-\n" + ";; Updated: " ,(format-time-string "%Y-%m-%d %H:%M:%S") "\n" + ";; Generated by 'doom profiles sync' or 'doom sync'.\n" + ";; DO NOT EDIT THIS BY HAND!\n" + ,(format "%S" doom-version) + (pcase (intern (getenv-internal "DOOMPROFILE")) + ,@(cl-loop + for (profile-name . bindings) in profiles + for deferred? + = (seq-find (fn! (and (memq (car-safe (cdr %)) '(:prepend :prepend? :append :append?)) + (not (stringp (car-safe %))))) + bindings) + collect + `(',profile-name + (let ,(if deferred? '(--deferred-vars--)) + ,@(cl-loop + for (var . val) in bindings + collect + (pcase (car-safe val) + (:path + `(,(if (stringp var) 'setenv 'setq) + ,var ,(cl-loop with form = `(expand-file-name ,(cadr val) user-emacs-directory) + for dir in (cddr val) + do (setq form `(expand-file-name ,dir ,form)) + finally return form))) + (:eval + (if (eq var '_) + (macroexp-progn (cdr val)) + `(,(if (stringp var) 'setenv 'setq) + ,var ,(macroexp-progn (cdr val))))) + (:plist + `(,(if (stringp var) 'setenv 'setq) + ,var ',(if (stringp var) + (prin1-to-string (cadr val)) + (cadr val)))) + ((or :prepend :prepend?) + (if (stringp var) + `(setenv ,var (concat ,val (getenv ,var))) + (setq deferred? t) + `(push (cons ',var + (lambda () + (dolist (item (list ,@(cdr val))) + ,(if (eq (car val) :append?) + `(add-to-list ',var item) + `(push item ,var))))) + --deferred-vars--))) + ((or :append :append?) + (if (stringp var) + `(setenv ,var (concat (getenv ,var) ,val)) + (setq deferred? t) + `(push (cons ',var + (lambda () + (dolist (item (list ,@(cdr val))) + ,(if (eq (car val) :append?) + `(add-to-list ',var item 'append) + `(set ',var (append ,var (list item))))))) + --deferred-vars--))) + (_ `(,(if (stringp var) 'setenv 'setq) ,var ',val)))) + ,@(when deferred? + `((defun --doom-profile-set-deferred-vars-- (_) + (dolist (var --deferred-vars--) + (when (boundp (car var)) + (funcall (cdr var)) + (setq --deferred-vars-- (delete var --deferred-vars--)))) + (unless --deferred-vars-- + (remove-hook 'after-load-functions #'--doom-profile-set-deferred-vars--) + (unintern '--doom-profile-set-deferred-vars-- obarray))) + (add-hook 'after-load-functions #'--doom-profile-set-deferred-vars--) + (--doom-profile-set-deferred-vars-- nil))))))) + ;; `user-emacs-directory' requires that it end in a directory + ;; separator, but users may forget this in their profile configs. + (setq user-emacs-directory (file-name-as-directory user-emacs-directory))) + :mode (cons #o600 #o700) + :printfn #'prin1) + (print-group! + (or (let ((byte-compile-warnings (if init-file-debug byte-compile-warnings)) + (byte-compile-dest-file-function + (lambda (_) (format "%s.elc" (file-name-sans-extension file))))) + (byte-compile-file file)) + ;; Do it again? So the errors/warnings are visible? + ;; (let ((byte-compile-warnings t)) + ;; (byte-compile-file file)) + (signal 'doom-profile-error (list file "Failed to byte-compile bootstrap file"))))) + (defun doom-profiles-autodetect (&optional _internal?) "Return all known profiles as a nested alist. @@ -145,176 +233,7 @@ caches them in `doom--profiles'. If RELOAD? is non-nil, refresh the cache." doom-version))) return t)) -(defun doom-profile<-id (id) - "Return a (NAME . VERSION) profile cons cell from an id string NAME@VERSION." - (save-match-data - (if (string-match "^\\([^@]+\\)@\\(.+\\)$" id) - (cons (match-string 1 id) - (match-string 2 id)) - (cons id (cdr doom-profile-default))))) -(defun doom-profile->id (profile) - "Return a NAME@VERSION id string from profile cons cell (NAME . VERSION)." - (cl-check-type profile cons) - (format "%s@%s" (car profile) (cdr profile))) - -;; TODO (defun doom-profile--read (profile) -;; (doom-profile-create )) - -;; TODO (defun doom-profile-initialize (profile-name &optional ref) -;; ) - -(defun doom-profiles-save (profiles &optional file) - "Generate a profile bootstrapper for Doom to load at startup." - (unless file - (setq file doom-profile-load-file)) - (doom-file-write - file (let ((profilesym (make-symbol "profile")) - (deferredsym (make-symbol "deferred-vars"))) - `(";; -*- lexical-binding: t; tab-width: 8; -*-\n" - ";; Updated: " ,(format-time-string "%Y-%m-%d %H:%M:%S") "\n" - ";; Generated by 'doom profiles sync' or 'doom sync'.\n" - ";; DO NOT EDIT THIS BY HAND!\n" - ,(format "%S" doom-version) - (pcase (intern (getenv-internal "DOOMPROFILE")) - ,@(cl-loop - for (profile-name . bindings) in profiles - for deferred? - = (seq-find (fn! (and (memq (car-safe (cdr %)) '(:prepend :prepend? :append :append?)) - (not (stringp (car-safe %))))) - bindings) - collect - `(',profile-name - (let ,(if deferred? '(--deferred-vars--)) - ,@(cl-loop - for (var . val) in bindings - collect - (pcase (car-safe val) - (:path - `(,(if (stringp var) 'setenv 'setq) - ,var ,(cl-loop with form = `(expand-file-name ,(cadr val) user-emacs-directory) - for dir in (cddr val) - do (setq form `(expand-file-name ,dir ,form)) - finally return form))) - (:eval - (if (eq var '_) - (macroexp-progn (cdr val)) - `(,(if (stringp var) 'setenv 'setq) - ,var ,(macroexp-progn (cdr val))))) - (:plist - `(,(if (stringp var) 'setenv 'setq) - ,var ',(if (stringp var) - (prin1-to-string (cadr val)) - (cadr val)))) - ((or :prepend :prepend?) - (if (stringp var) - `(setenv ,var (concat ,val (getenv ,var))) - (setq deferred? t) - `(push (cons ',var - (lambda () - (dolist (item (list ,@(cdr val))) - ,(if (eq (car val) :append?) - `(add-to-list ',var item) - `(push item ,var))))) - --deferred-vars--))) - ((or :append :append?) - (if (stringp var) - `(setenv ,var (concat (getenv ,var) ,val)) - (setq deferred? t) - `(push (cons ',var - (lambda () - (dolist (item (list ,@(cdr val))) - ,(if (eq (car val) :append?) - `(add-to-list ',var item 'append) - `(set ',var (append ,var (list item))))))) - --deferred-vars--))) - (_ `(,(if (stringp var) 'setenv 'setq) ,var ',val)))) - ,@(when deferred? - `((defun --doom-profile-set-deferred-vars-- (_) - (dolist (var --deferred-vars--) - (when (boundp (car var)) - (funcall (cdr var)) - (setq --deferred-vars-- (delete var --deferred-vars--)))) - (unless --deferred-vars-- - (remove-hook 'after-load-functions #'--doom-profile-set-deferred-vars--) - (unintern '--doom-profile-set-deferred-vars-- obarray))) - (add-hook 'after-load-functions #'--doom-profile-set-deferred-vars--) - (--doom-profile-set-deferred-vars-- nil))))))) - ;; `user-emacs-directory' requires that it end in a directory - ;; separator, but users may forget this in their profile configs. - (setq user-emacs-directory (file-name-as-directory user-emacs-directory)))) - :mode (cons #o600 #o700) - :printfn #'pp) - (print-group! - (or (let ((byte-compile-warnings (if init-file-debug byte-compile-warnings)) - (byte-compile-dest-file-function - (lambda (_) (format "%s.elc" (file-name-sans-extension file))))) - (byte-compile-file file)) - ;; Do it again? So the errors/warnings are visible? - ;; (let ((byte-compile-warnings t)) - ;; (byte-compile-file file)) - (signal 'doom-profile-error (list file "Failed to byte-compile bootstrap file"))))) - -(defun doom-profile-p (profile-name) - "Return t if PROFILE-NAME is a valid and existing profile." - (when (stringp profile-name) - (setq profile-name (intern profile-name))) - (and (assq profile-name (doom-profiles)) - t)) - -(defun doom-profile-get (profile-name &optional property null-value) - "Return PROFILE-NAME's PROFILE, otherwise its PROPERTY, otherwise NULL-VALUE." - (when (stringp profile-name) - (setq profile-name (intern profile-name))) - (if-let (profile (assq profile-name (doom-profiles))) - (if property - (if-let (propval (assq property (cdr profile))) - (cdr propval) - null-value) - profile) - null-value)) - -(defun doom-profile-emacs-dir (profile-name) - "Return the `user-emacs-directory' for PROFILE-NAME. - -If the profile doesn't specify one, fall back to `doom-emacs-dir'." - (doom-profile-get profile-name 'user-emacs-directory doom-emacs-dir)) - -(defun doom-profile-init-file (&optional profile-id version) - "Return the init file for PROFILE-ID at VERSION. - -Defaults to the profile at `doom-profile-default'." - (cl-destructuring-bind (profile . version) - (if (and (stringp profile-id) (null version)) - (doom-profile<-id profile-id) - (cl-check-type profile-id (or null string)) - (cl-check-type version (or null string)) - (cons (or profile-id ;; (car doom-profile-default) - ) - (or version ;; (cdr doom-profile-default) - ))) - (file-name-concat doom-data-dir - profile "@" version - (format doom-profile-init-file-name emacs-major-version)))) - - -;; -;;; Data structures - -;; TODO - - -;; -;;; API - -;; TODO (defun doom-profile-create (name)) - -;; TODO (defun doom-profile-hash (profile)) - -;; TODO (defmacro with-profile! (profile &rest body)) - - -;; ;;; Generators (defun doom-profile-generate (&optional _profile regenerate-only?) @@ -322,8 +241,8 @@ Defaults to the profile at `doom-profile-default'." (doom-initialize-packages) (let* ((default-directory doom-profile-dir) (init-dir doom-profile-init-dir-name) - (init-file doom-profile-init-file-name)) - (print! (start "(Re)building profile in %s/...") (dirname doom-profile-dir)) + (init-file (doom-profile-init-file doom-profile t))) + (print! (start "(Re)building profile in %s/...") (path default-directory)) (condition-case-unless-debug e (with-file-modes #o750 (print-group! @@ -343,7 +262,9 @@ Defaults to the profile at `doom-profile-default'." (pcase-dolist (`(,file . ,fn) doom-profile-generators) (let ((file (doom-path init-dir file))) (doom-log "Building %s..." file) - (doom-file-write file (funcall fn)))))) + (insert "\n;;;; START " file " ;;;;\n") + (doom-file-write file (funcall fn) :printfn #'prin1) + (insert "\n;;;; END " file " ;;;;\n"))))) (with-file! init-file (insert ";; -*- coding: utf-8; lexical-binding: t; -*-\n" ";; This file was autogenerated; do not edit it by hand!\n") @@ -351,11 +272,19 @@ Defaults to the profile at `doom-profile-default'." ;; up/downgraded. This is because byte-code isn't backwards ;; compatible, and many packages (including Doom), bake in absolute ;; paths into their caches that need to be refreshed. - (prin1 `(unless (equal doom-version ,doom-version) - (error ,(concat - "The installed version of Doom (%s) has changed (to %s) since last " - "'doom sync'. Run 'doom sync' to bring Doom up to speed") - ,doom-version doom-version)) + (prin1 `(or (equal doom-version ,doom-version) + (error ,(concat + "The installed version of Doom has changed since the last 'doom sync'.\n\n" + "Run 'doom sync' to fix this.") + ,doom-version doom-version)) + (current-buffer)) + (prin1 `(when (and (or initial-window-system + (daemonp)) + doom-env-file) + (doom-load-envvars-file doom-env-file 'noerror)) + (current-buffer)) + (prin1 `(with-doom-context '(module init) + (doom-load (file-name-concat doom-user-dir ,doom-module-init-file) t)) (current-buffer)) (dolist (file (doom-glob init-dir "*.el")) (print-group! :level 'info @@ -374,8 +303,7 @@ Defaults to the profile at `doom-profile-default'." ;; FIX: Make sure this only runs at startup to protect us Emacs' interpreter ;; re-evaluating this file when lazy-loading dynamic docstrings from the ;; byte-compiled init file. - `((when (or (doom-context-p 'init) - (doom-context-p 'reload)) + `((defun doom--startup-vars () ,@(cl-loop for var in doom-autoloads-cached-vars if (boundp var) collect `(set-default ',var ',(symbol-value var))) @@ -430,49 +358,52 @@ Defaults to the profile at `doom-profile-default'." if (doom-module-locate-path key file) collect (module-loader key it)))) ;; FIX: Same as above (see `doom-profile--generate-init-vars'). - `((if (or (doom-context-p 'init) - (doom-context-p 'reload)) - (with-doom-context 'modules - (set 'doom-modules ',doom-modules) - (set 'doom-disabled-packages ',doom-disabled-packages) - ;; Cache module state and flags in symbol plists for quick lookup - ;; by `modulep!' later. - ,@(cl-loop - for (category . modules) in (seq-group-by #'car config-modules-list) - collect - `(setplist ',category - (quote ,(cl-loop for (_ . module) in modules - nconc `(,module ,(doom-module->context (cons category module))))))) - (let ((old-custom-file custom-file)) + `((defun doom--startup-modules () + (with-doom-context 'module + (set 'doom-modules ',doom-modules) + (set 'doom-disabled-packages ',doom-disabled-packages) + ;; Cache module state and flags in symbol plists for quick lookup + ;; by `modulep!' later. + ,@(cl-loop + for (category . modules) in (seq-group-by #'car config-modules-list) + collect + `(setplist ',category + (quote ,(cl-loop for (_ . module) in modules + nconc `(,module ,(doom-module->context (cons category module))))))) + (let ((old-custom-file custom-file)) + (with-doom-context 'init ,@(module-list-loader pre-init-modules init-file) (doom-run-hooks 'doom-before-modules-init-hook) ,@(module-list-loader init-modules init-file) - (doom-run-hooks 'doom-after-modules-init-hook) + (doom-run-hooks 'doom-after-modules-init-hook)) + (with-doom-context 'config (doom-run-hooks 'doom-before-modules-config-hook) ,@(module-list-loader config-modules config-file) (doom-run-hooks 'doom-after-modules-config-hook) - ,@(module-list-loader post-config-modules config-file) - (when (eq custom-file old-custom-file) - (doom-load custom-file 'noerror))))))))) + ,@(module-list-loader post-config-modules config-file)) + (when (eq custom-file old-custom-file) + (doom-load custom-file 'noerror))))))))) (defun doom-profile--generate-doom-autoloads () - (doom-autoloads--scan - (append (doom-glob doom-core-dir "lib/*.el") - (cl-loop for dir - in (append (doom-module-load-path) - (list doom-user-dir)) - if (doom-glob dir "autoload.el") collect (car it) - if (doom-glob dir "autoload/*.el") append it) - (mapcan #'doom-glob doom-autoloads-files)) - nil)) + `((defun doom--startup-module-autoloads () + ,@(doom-autoloads--scan + (append (doom-glob doom-core-dir "lib/*.el") + (cl-loop for dir + in (append (doom-module-load-path) + (list doom-user-dir)) + if (doom-glob dir "autoload.el") collect (car it) + if (doom-glob dir "autoload/*.el") append it) + (mapcan #'doom-glob doom-autoloads-files)) + nil)))) (defun doom-profile--generate-package-autoloads () - (doom-autoloads--scan - (mapcar #'straight--autoloads-file - (nreverse (seq-difference (hash-table-keys straight--build-cache) - doom-autoloads-excluded-packages))) - doom-autoloads-excluded-files - 'literal)) + `((defun doom--startup-package-autoloads () + ,@(doom-autoloads--scan + (mapcar #'straight--autoloads-file + (nreverse (seq-difference (hash-table-keys straight--build-cache) + doom-autoloads-excluded-packages))) + doom-autoloads-excluded-files + 'literal)))) -(provide 'doom-profiles) -;;; doom-profiles.el ends here +(provide 'doom-lib '(profiles)) +;;; profiles.el ends here