doomemacs/core/cli/packages.el

;; -*- no-byte-compile: t; -*-
;;; core/cli/packages.el

(defmacro doom--ensure-autoloads-while (&rest body)
  `(progn
     (doom-reload-core-autoloads)
     (when (progn ,@body)
       (doom-reload-package-autoloads 'force-p))
     t))


;;
;;; Dispatchers

(def-command! (update u) ()
  "Updates packages.

This excludes packages whose `package!' declaration contains a non-nil :freeze
or :ignore property."
  (doom--ensure-autoloads-while
   (straight-check-all)
   (when (doom-packages-update doom-auto-accept)
     (doom-packages-rebuild doom-auto-accept)
     t)))

(def-command! (rebuild b) ()
  "Rebuilds all installed packages.

This ensures that all needed files are symlinked from their package repo and
their elisp files are byte-compiled."
  (doom--ensure-autoloads-while
   (doom-packages-rebuild doom-auto-accept (member "all" args))))

(def-command! (purge p) ()
  "Deletes any unused packages and package repos.

You should run this once in a while, as repos tend to build up over time."
  (doom--ensure-autoloads-while
   (straight-check-all)
   (doom-packages-purge doom-auto-accept)))

;; (def-command! rollback () ; TODO rollback
;;   "<Not implemented yet>"
;;   (user-error "Not implemented yet, sorry!"))


;;
;;; Library

(defun doom-packages-install (&optional auto-accept-p)
  "Installs missing packages.

This function will install any primary package (i.e. a package with a `package!'
declaration) or dependency thereof that hasn't already been.

Unless AUTO-ACCEPT-P is non-nil, this function will prompt for confirmation with
a list of packages that will be installed."
  (print! "> Installing & building packages...")
  (print-group!
   (let ((n 0))
     (dolist (package (hash-table-keys straight--recipe-cache))
       (straight--with-plist (gethash package straight--recipe-cache)
           (local-repo)
         (let ((existed-p (file-directory-p (straight--repos-dir package))))
           (condition-case-unless-debug e
               (and (straight-use-package (intern package) nil nil " ")
                    (not existed-p)
                    (file-directory-p (straight--repos-dir package))
                    (cl-incf n))
             (error
              (signal 'doom-package-error
                      (list e (straight--process-get-output))))))))
     (if (= n 0)
         (ignore (print! (success "No packages need to be installed")))
       (print! (success "Installed & built %d packages") n)
       t))))


(defun doom-packages-rebuild (&optional auto-accept-p all)
  "(Re)build all packages."
  (print! (start "(Re)building %spackages...") (if all "all " ""))
  (print-group!
   (let ((n 0))
     (if all
         (let ((straight--packages-to-rebuild :all)
               (straight--packages-not-to-rebuild (make-hash-table :test #'equal)))
           (dolist (package (hash-table-keys straight--recipe-cache))
             (straight-use-package
              (intern package) nil (lambda (_) (cl-incf n) nil) " ")))
       (let ((straight-check-for-modifications '(find-when-checking)))
         (straight-check-all)
         (dolist (recipe (hash-table-values straight--recipe-cache))
           (straight--with-plist recipe (package local-repo no-build)
             (unless (or no-build (null local-repo))
               ;; REVIEW We do these modification checks manually because
               ;;        Straight's checks seem to miss stale elc files. Need
               ;;        more tests to confirm this.
               (when (or (gethash package straight--cached-package-modifications)
                         (file-newer-than-file-p (straight--repos-dir local-repo)
                                                 (straight--build-dir package))
                         (cl-loop for file
                                  in (doom-files-in (straight--build-dir package)
                                                    :match "\\.el$"
                                                    :full t)
                                  for elc-file = (byte-compile-dest-file file)
                                  if (and (file-exists-p elc-file)
                                          (file-newer-than-file-p file elc-file))
                                  return t))
                 (print! (info "Rebuilding %s") package)
                 ;; REVIEW `straight-rebuild-package' alone wasn't enough. Why?
                 (delete-directory (straight--build-dir package) 'recursive)
                 (straight-rebuild-package package)
                 (cl-incf n)))))))
     (if (= n 0)
         (ignore (print! (success "No packages need rebuilding")))
       (print! (success "Rebuilt %d package(s)" n))
       t))))


(defun doom-packages-update (&optional auto-accept-p)
  "Updates packages.

Unless AUTO-ACCEPT-P is non-nil, this function will prompt for confirmation with
a list of packages that will be updated."
  (print! (start "Scanning for outdated packages (this may take a while)..."))
  (print-group!
   ;; REVIEW Does this fail gracefully enough? Is it error tolerant?
   ;; TODO Add version-lock checks; don't want to spend all this effort on
   ;;      packages that shouldn't be updated
   (condition-case e
       (let (futures)
         (dolist (group (seq-partition (hash-table-values straight--repo-cache) 8))
           (push (async-start
                  `(lambda ()
                     (setq load-path ',load-path
                           doom-modules ',doom-modules)
                     (load ,(concat doom-core-dir "core.el"))
                     (let (packages)
                       (when (require 'straight nil t)
                         (dolist (recipe ',group)
                           (straight--with-plist recipe (package local-repo)
                             (when (and local-repo (straight--repository-is-available-p recipe))
                               (straight-fetch-package package)
                               ;; REVIEW Isn't there a better way to get this information? Maybe with `vc'?
                               (let* ((default-directory (straight--repos-dir local-repo))
                                      (n (string-to-number
                                          (shell-command-to-string "git rev-list --right-only --count HEAD..@'{u}'")))
                                      (pretime
                                       (string-to-number
                                        (shell-command-to-string "git log -1 --format=%at HEAD")))
                                      (time
                                       (string-to-number
                                        (shell-command-to-string "git log -1 --format=%at FETCH_HEAD"))))
                                 (when (> n 0)
                                   (push (list n pretime time recipe)
                                         packages)))))))
                       (nreverse packages))))
                 futures))
         (let ((total (length futures))
               (futures (nreverse futures))
               (specs '(t)))
           (while futures
             (while (not (async-ready (car futures)))
               (sleep-for 2)
               (print! "."))
             (nconc specs (async-get (pop futures))))
           (terpri)
           (if-let (specs (delq nil (cdr specs)))
               (if (or auto-accept-p
                       (y-or-n-p
                        (format! "%s\n\nThere %s %d package%s available to update. Update them?"
                                 (mapconcat
                                  (lambda (spec)
                                    (cl-destructuring-bind (n pretime time recipe) spec
                                      (straight--with-plist recipe (package)
                                        (format! "+ %-33s %s commit(s) behind   %s -> %s"
                                                 (yellow package) (yellow n)
                                                 (format-time-string "%Y%m%d" pretime)
                                                 (format-time-string "%Y%m%d" time)))))
                                  specs
                                  "\n")
                                 (if (cdr specs) "are" "is")
                                 (length specs)
                                 (if (cdr specs) "s" ""))))
                   (terpri)
                   (dolist (spec specs t)
                     (cl-destructuring-bind (n pretime time recipe) spec
                       (straight--with-plist recipe (local-repo package)
                         (let ((default-directory (straight--repos-dir local-repo)))
                           (print! (start "Updating %S") package)
                           ;; HACK `straight' doesn't assume it would ever be used
                           ;; non-interactively, but here we are. If the repo is
                           ;; dirty, the command will lock up, waiting for
                           ;; interaction that will never come, so discard all local
                           ;; changes. Doom doesn't want you modifying those anyway.
                           (and (straight--get-call "git" "reset" "--hard")
                                (straight--get-call "git" "clean" "-ffd"))
                           (straight-merge-package package)
                           ;; HACK `straight-rebuild-package' doesn't pick up that
                           ;; this package has changed, so we do it manually. Is
                           ;; there a better way?
                           (run-hook-with-args 'straight-use-package-pre-build-functions package)
                           (straight--build-package recipe "   "))
                         (with-current-buffer (straight--process-get-buffer)
                           (with-silent-modifications
                             (erase-buffer))))))
                 (print! (info "Aborted update"))
                 nil)
             (print! (success "No packages to update"))
             nil)))
     (error
      (message "Output:\n%s" (straight--process-get-output))
      (signal (car e) (error-message-string e))))))


(defun doom--packages-to-purge ()
  (let (builds repos)
    (dolist (name (straight--directory-files (straight--repos-dir)))
      (unless (straight--checkhash name straight--repo-cache)
        (push name repos)))
    (dolist (name (straight--directory-files (straight--build-dir)))
      (unless (gethash name straight--profile-cache)
        (push name builds)))
    (straight-prune-build-cache)
    (list builds repos)))

(defun doom-packages-purge (&optional auto-accept-p)
  "Auto-removes orphaned packages and repos.

An orphaned package is a package that isn't a primary package (i.e. doesn't have
a `package!' declaration) or isn't depended on by another primary package.

Unless AUTO-ACCEPT-P is non-nil, this function will prompt for confirmation with
a list of packages that will be removed."
  (print! (start "Searching for orphaned packages..."))
  (cl-destructuring-bind (builds repos) (doom--packages-to-purge)
    (unless (bound-and-true-p package--initialized)
      (package-initialize))
    (print-group!
     (let ((packages (append builds (mapcar #'car package-alist) nil)))
       (if (not packages)
           (ignore (print! (success "No orphaned packages to purge")))
         (or auto-accept-p
             (y-or-n-p
              (format! "\n%s\n\n%d packages are orphaned. Purge them (for the Emperor)?"
                       (mapconcat (lambda (pkgs)
                                    (mapconcat (lambda (p) (format "  + %-20.20s" p))
                                               pkgs
                                               ""))
                                  (seq-partition (cl-sort (copy-sequence packages) #'string-lessp)
                                                 3)
                                  "\n")
                       (length packages)))
             (user-error "Aborted"))
         (let ((n 0))
           (dolist (dir (append (mapcar #'straight--repos-dir repos)
                                (mapcar #'straight--build-dir builds)))
             (print! (info "Deleting %S") (relpath dir (straight--dir)))
             (delete-directory dir 'recursive)
             (unless (file-directory-p dir)
               (cl-incf n)))
           (straight-prune-build-cache)
           (when (file-directory-p package-user-dir)
             (delete-directory package-user-dir t)
             t)
           (> n 0)))))))