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

(defcli! (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)
   (doom-packages-update doom-auto-accept)))

(defcli! (rebuild build b) (&rest args)
  "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 "-f" args))))

(defcli! (purge p) (&rest args)
  "Deletes any unused ELPA packages, straight builds, and (optionally) repos.

By default, this does not purge repos.

Available options:

--no-elpa    Don't purge ELPA packages
--no-builds  Don't purge unneeded (built) packages
--repos      Purge unused repos"
  (doom--ensure-autoloads-while
   (straight-check-all)
   (doom-packages-purge (not (member "--no-elpa" args))
                        (not (member "--no-builds" args))
                        (or (member "-r" args)
                            (member "--repos" args))
                        doom-auto-accept)))

;; (defcli! 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) " ")))
       (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 (ignore-errors
                         (gethash package straight--packages-to-rebuild))
                       (gethash package straight--cached-package-modifications)
                       (not (file-directory-p (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))
               (let ((straight-use-package-pre-build-functions
                      straight-use-package-pre-build-functions))
                 (add-hook 'straight-use-package-pre-build-functions
                           (lambda (&rest _) (cl-incf n)))
                 (let ((straight--packages-to-rebuild :all)
                       (straight--packages-not-to-rebuild (make-hash-table :test #'equal)))
                   (straight-use-package (intern package) nil nil " "))
                 (straight--byte-compile-package recipe)
                 (dolist (dep (straight--get-dependencies package))
                   (when-let (recipe (gethash dep straight--recipe-cache))
                     (straight--byte-compile-package recipe)))))))))
     (if (= n 0)
         (ignore (print! (success "No packages need rebuilding")))
       (doom--finalize-straight)
       (print! (success "Rebuilt %d package(s)" n))
       t))))


(defun doom--packages-remove-outdated-f (packages)
  (async-start
   `(lambda ()
      (setq load-path ',load-path
            doom-modules ',doom-modules)
      (condition-case e
          (let (packages errors)
            (load ,(concat doom-core-dir "core.el"))
            (dolist (recipe ',group)
              (condition-case e
                  (straight--with-plist recipe
                      (package local-repo remote upstream-repo upstream-host)
                    ;; HACK There's a contingency of `straight-fetch-package'
                    ;; where it will pop up a window for confirmation, but this
                    ;; window is invisible because a) this command runs in a
                    ;; headless session and b) this code runs in an async child
                    ;; process, so we ensure the remotes are correctly set up to
                    ;; prevent that contingency.
                    (when (and local-repo (straight--repository-is-available-p recipe))
                      (when-let*
                          ((url (ignore-errors (straight--get-call "git" "remote" "get-url" remote)))
                           (desired-url (straight-vc-git--encode-url upstream-repo upstream-host)))
                        (unless (straight-vc-git--urls-compatible-p url desired-url)
                          (straight--get-call "git" "remote" "remove" remote)
                          (straight--get-call "git" "remote" "add" remote desired-url)
                          (straight--get-call "git" "fetch" remote)))
                      (straight-fetch-package package)
                      ;; REVIEW Is there no better way to get this information?
                      (let* ((default-directory (straight--repos-dir local-repo))
                             (n (string-to-number
                                 (straight--get-call "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
                               ;; HACK `straight--get-call' has a higher
                               ;; failure rate when querying FETCH_HEAD; not
                               ;; sure why. Doing this manually, with
                               ;; `shell-command-to-string' works fine.
                               (shell-command-to-string "git log -1 --format=%at FETCH_HEAD"))))
                        (with-current-buffer (straight--process-get-buffer)
                          (with-silent-modifications
                            (print! (debug (autofill "%s") (indent 2 (buffer-string))))
                            (erase-buffer)))
                        (when (> n 0)
                          (push (list n pretime time recipe)
                                packages)))))
                (error
                 (push (list package e (string-trim (or (straight--process-get-output) "")))
                       errors))))
            (if errors
                (cons 'error errors)
              (cons 'ok (nreverse packages))))
        (error
         (cons 'error e))))))


(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
   (let ((futures
          (or (cl-loop for group
                       in (seq-partition (hash-table-values straight--repo-cache)
                                         8)
                       if (doom--packages-remove-outdated-f group)
                       collect it)
              (error! "Failed to create any threads"))))
     (condition-case-unless-debug e
         (let ((total (length futures))
               specs)
           (while futures
             (print! ". %.0f%%" (* (/ (- total (length futures))
                                      (float total))
                                   100))
             (while (not (async-ready (car futures)))
               (sleep-for 2)
               (print! "."))
             (cl-destructuring-bind (status . result)
                 (or (async-get (pop futures))
                     (cons nil nil))
               (cond ((null status)
                      (error "Thread returned an invalid result: %S" errors result))
                     ((eq status 'error)
                      (error "There were errors:\n\n%s"
                             (if (and (listp result)
                                      (symbolp (car result)))
                                 (prin1-to-string result)
                               (mapconcat (lambda (e)
                                            (format! " - %s: %s" (yellow (car e)) (cdr e)))
                                          result
                                          "\n"))))
                     ((eq status 'ok)
                      (print! (debug "Appended %S to package list") (or result "nothing"))
                      (appendq! specs result))
                     ((error "Thread returned a non-standard status: %s\n\n%s"
                             status result)))))
           (print! ". 100%%")
           (terpri)
           (if-let (specs (delq nil specs))
               (if (not
                    (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" "")))))
                   (ignore (print! (info "Aborted update")))
                 (terpri)
                 (straight--make-package-modifications-available)
                 (let ((straight--packages-to-rebuild (make-hash-table :test #'equal))
                       (straight--packages-not-to-rebuild (make-hash-table :test #'equal)))
                   (dolist (spec specs)
                     (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' assumes it won't be used in a
                           ;; noninteractive session, 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?
                           (ignore-errors
                             (delete-directory (straight--build-dir package) 'recursive))
                           (puthash package t straight--packages-to-rebuild)
                           (cl-incf n))
                         (with-current-buffer (straight--process-get-buffer)
                           (with-silent-modifications
                             (print! (debug (autofill "%s") (indent 2 (buffer-string))))
                             (erase-buffer))))))
                   (doom--finalize-straight)
                   (doom-packages-rebuild auto-accept-p))
                 t)
             (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)))

(defmacro doom--packages-purge (packages label auto-accept-p &rest files)
  (declare (indent defun))
  `(let ((packages ,packages)
         (label ,label))
     (if (not packages)
         (ignore (print! (success "No orphaned %s(s) to purge" label)))
       (if (not (or ,auto-accept-p
                    (y-or-n-p
                     (format! "\n%s\n\n%d %s(s) 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)
                              label))))
           (ignore (print! (warn "Aborted")))
         (let ((n 0))
           (print! (start "Pruning %ss..." label))
           (print-group!
            (dolist (it packages)
              (print! (info "Deleting %s/%s") label it)
              (dolist (path (list ,@files))
                (cond ((file-directory-p path)
                       (delete-directory path 'recursive))
                      ((file-regular-p path)
                       (delete-file path)))
                (if (file-exists-p path)
                    (print! (error "Failed to find %s/%s") label it)
                  (cl-incf n))))
            (if (= n 0)
                (ignore (print! (warn "Didn't prune any %s(s) for some reason" label)))
              (print! (success "Pruned %d %s(s)" n label))
              (doom--finalize-straight)
              t)))))))

(defun doom-packages-purge (&optional elpa-p builds-p repos-p 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.

If BUILDS-P, include straight package builds.
If REPOS-P, include straight repos.
If ELPA-P, include packages installed with package.el (M-x package-install).

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)
    (let (success)
      (print-group!
       (if builds-p
           (and (doom--packages-purge builds "build" auto-accept-p
                  (straight--build-dir it)
                  (straight--modified-file it))
                (setq success t)
                (straight-prune-build-cache))
         (print! (info "Skipping builds")))
       (if repos-p
           (and (doom--packages-purge repos "repo" auto-accept-p
                  (straight--repos-dir it))
                (setq success t))
         (print! (info "Skipping repos")))
       (if (not elpa-p)
           (print! (info "Skipping elpa packages"))
         (unless (bound-and-true-p package--initialized)
           (package-initialize))
         (and (doom--packages-purge (mapcar #'symbol-name (mapcar #'car package-alist))
                "package" auto-accept-p
                (package-desc-dir (cadr (assq (intern it) package-alist))))
              (setq success t))
         (when (file-directory-p package-user-dir)
           (delete-directory package-user-dir t)))
       (when success
         (doom--finalize-straight)
         t)))))