paradox-execute.el

;;; paradox-execute.el --- executing package transactions -*- lexical-binding:t -*-

;; Copyright (C) 2014-2015 Artur Malabarba <bruce.connor.am@gmail.com>

;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
;; Prefix: paradox
;; Separator: -

;;; License:
;;
;; This file is NOT part of GNU Emacs.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License
;; as published by the Free Software Foundation; either version 2
;; of the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;

;;; Commentary:
;; 
;; Functions related to executing package-menu transactions.
;; Everything that happens when you hit `x' is in here.


;;; Code:
(require 'cl-lib)
(require 'seq)

(require 'package)
(require 'paradox-core)
(require 'paradox-github)

(defgroup paradox-execute nil
  "Paradox Packages Menu configurations."
  :prefix "paradox-"
  :package-version '(paradox . "2.0")
  :group 'paradox)

(defvar paradox--current-filter)

;;; Customization Variables
(defcustom paradox-execute-asynchronously 'ask
  "Whether the install/delete/upgrade should be asynchronous.
Possible values are:
  t, which means always;
  nil, which means never;
  ask, which means ask each time."
  :type '(choice (const :tag "Always" t)
                 (const :tag "Never" nil)
                 (const :tag "Ask each time" ask))
  :package-version '(paradox . "2.0")
  :group 'paradox-execute)

(defcustom paradox-async-display-buffer-function #'display-buffer
  "Function used to display *Paradox Report* buffer after asynchronous upgrade.
Set this to nil to avoid displaying the buffer. Or set this to a
function like `display-buffer' or `pop-to-buffer'.

This is only used if `paradox-menu-execute' was given a non-nil
NOQUERY argument. Otherwise, only a message is displayed."
  :type '(choice (const :tag "Don't display the buffer" nil)
                 function)
  :package-version '(paradox . "2.0")
  :group 'paradox-execute)


;;; Execution Hook
(defvar paradox-after-execute-functions nil
  "List of functions run after performing package transactions.
These are run after a set of installation, deletion, or upgrades
has been performed. Each function in this hook must take a single
argument. An associative list of the form

    ((SYMBOL . DATA) (SYMBOL . DATA) ...)

This list contains the following entries, describing what
occurred during the execution:

  SYMBOL      DATA
  `installed' List of installed packages.
  `deleted'   List of deleted packages.
  `activated' List of activated packages.
  `error'     List of errors.
  `async'     Non-nil if transaction was performed asynchronously.
  `noquery'   The NOQUERY argument given to `paradox-menu-execute'.")
(put 'risky-local-variable-p 'paradox-after-execute-functions t)
(mapc (lambda (x) (add-hook 'paradox-after-execute-functions x t))
      '(paradox--activate-if-asynchronous
        paradox--refresh-package-buffer
        paradox--report-buffer-print
        paradox--report-buffer-display-if-noquery
        paradox--report-message
        ))

(defun paradox--refresh-package-buffer (_)
  "Refresh the *Packages* buffer, if it exists."
  (let ((buf (get-buffer "*Packages*")))
    (when (buffer-live-p buf)
      (with-current-buffer buf
        (revert-buffer)))))

(defun paradox--activate-if-asynchronous (alist)
  "Activate packages after an asynchronous operation.
Argument ALIST describes the operation."
  (let-alist alist
    (when .async
      (dolist (pkg .activated)
        (if (fboundp 'package--list-loaded-files)
            (package-activate-1 pkg 'reload)
          (package-activate-1 pkg))))))

(defun paradox--print-package-list (list)
  "Print LIST at point."
  (let* ((width (apply #'max
                  (mapcar (lambda (x) (string-width (symbol-name (package-desc-name x))))
                          list)))
         (tabulated-list-format
          `[("Package" ,(1+ width) nil)
            ("Version" 0 nil)])
         (tabulated-list-padding 2))
    (mapc
     (lambda (p) (tabulated-list-print-entry
             p
             `[,(symbol-name (package-desc-name p))
               ,(package-version-join (package-desc-version p))]))
     list)))

(defun paradox--report-buffer-print (alist)
  "Print a transaction report in *Package Report* buffer.
Possibly display the buffer or message the user depending on the
situation.
Argument ALIST describes the operation."
  (let-alist alist
    (let ((buf (get-buffer-create "*Paradox Report*"))
          (inhibit-read-only t))
      (with-current-buffer buf
        (goto-char (point-max))
        ;; TODO: Write our own mode for this.
        (special-mode)
        (insert "\n\n")
        (save-excursion
          (insert (format-time-string "Package transaction finished. %c\n"))
          (when .error
            (insert "Errors:\n  ")
            (dolist (it .error)
              (princ it (current-buffer))
              (insert "\n"))
            (insert "\n\n"))
          (when .installed
            (insert  "Installed:\n")
            (paradox--print-package-list .installed)
            (insert "\n"))
          (when .deleted
            (insert  "Deleted:\n")
            (paradox--print-package-list .deleted)
            (insert "\n")))))))

(defun paradox--report-buffer-display-if-noquery (alist)
  "Display report buffer if `paradox-execute' was called with a NOQUERY prefix.
ALIST describes the transaction.
`paradox-async-display-buffer-function' is used if transaction
was asynchronous. Otherwise, `pop-to-buffer' is used."
  (let-alist alist
    ;; The user has never seen the packages in this transaction. So
    ;; we display them in a buffer.
    (when (or .noquery .error)
      (let ((buf (get-buffer "*Paradox Report*")))
        (when (buffer-live-p buf)
          (cond
           ;; If we're async, the user might be doing something else, so
           ;; we don't steal focus.
           ((and .async paradox-async-display-buffer-function)
            (funcall paradox-async-display-buffer-function buf))
           ;; If we're not async, just go ahead and pop.
           ((or (not .async)
                ;; If there's an error, display the buffer even if
                ;; `paradox-async-display-buffer-function' is nil.
                .error)
            (pop-to-buffer buf))))))))

(defun paradox--report-message (alist)
  "Message the user about the executed transaction.
ALIST describes the transaction."
  (let-alist alist
    (message "%s%s"
      (paradox--format-message nil .installed .deleted)
      (if (memq 'paradox--report-buffer-print paradox-after-execute-functions)
          " See the buffer *Paradox Report* for more details." ""))
    (when .errors
      (message "Errors encountered during the operation: %S\n%s"
        .errors
        (if (memq 'paradox--report-buffer-print paradox-after-execute-functions)
            " See the buffer *Paradox Report* for more details." "")))))


;;; Execution
(defun paradox-menu-execute (&optional noquery)
  "Perform marked Package Menu actions.
Packages marked for installation are downloaded and installed;
packages marked for deletion are removed.

Afterwards, if `paradox-automatically-star' is t, automatically
star new packages, and unstar removed packages.  Upgraded packages
aren't changed.

Synchronicity of the actions depends on
`paradox-execute-asynchronously'.  Optional argument NOQUERY
non-nil means do not ask the user to confirm.  If asynchronous,
never ask anyway."
  (interactive "P")
  (unless (derived-mode-p 'paradox-menu-mode)
    (error "The current buffer is not in Paradox Menu mode"))
  (when (and (stringp paradox-github-token)
             (eq paradox-automatically-star 'unconfigured))
    (customize-save-variable
     'paradox-automatically-star
     (y-or-n-p "When you install new packages would you like them to be automatically starred?
\(They will be unstarred when you delete them) ")))
  (when (and (stringp paradox--current-filter)
             (string-match "Upgradable" paradox--current-filter))
    (setq tabulated-list-sort-key '("Status" . nil))
    (setq paradox--current-filter nil))
  (paradox--menu-execute-1 noquery))

(defmacro paradox--perform-package-transaction (install delete)
  "Install all packages from INSTALL and delete those from DELETE.
Return an alist with properties listing installed,
deleted, and activated packages, and errors."
  `(let (activated installed deleted errored)
     (advice-add #'package-activate-1 :after
                 (lambda (pkg &rest _)
                   (ignore-errors (push pkg activated)))
                 '((name . paradox--track-activated)))
     (condition-case err
         (progn
           (dolist (pkg ,install)
             ;; 2nd arg introduced in 25.
             (if (version<= "25" emacs-version)
                 (package-install pkg 'dont-select)
               (package-install pkg))
             (push pkg installed))
           (let ((delete-list ,delete))
             (dolist (pkg (if (fboundp 'package--sort-by-dependence)
                              (package--sort-by-dependence delete-list)
                            delete-list))
               (condition-case err
                   (progn (package-delete pkg)
                          (push pkg deleted))
                 (error (push err errored))))))
       (error (push err errored)))
     (advice-remove #'package-activate-1 'paradox--track-activated)
     (list (cons 'installed (nreverse installed))
           (cons 'deleted   (nreverse deleted))
           (cons 'activated (nreverse activated))
           (cons 'error     (nreverse errored)))))

(defvar paradox--current-filter)

(declare-function async-inject-variables "async")
(defun paradox--menu-execute-1 (&optional noquery)
  "Implementation used by `paradox-menu-execute'.
NOQUERY, if non-nil, means to execute without prompting the
user."
  (let ((before-alist (paradox--repo-alist))
        install-list delete-list)
    (save-excursion
      (goto-char (point-min))
      (let ((p (point))
            (inhibit-read-only t))
        (while (not (eobp))
          (let ((c (char-after)))
            (if (eq c ?\s)
                (forward-line 1)
              (push (tabulated-list-get-id)
                    (pcase c
                      (`?D delete-list)
                      (`?I install-list)))
              (delete-region p (point))
              (forward-line 1)
              (setq p (point)))))
        (when (or delete-list install-list)
          (delete-region p (point))
          (ignore-errors
            (set-window-start (selected-window) (point-min))))))
    (if (not (or delete-list install-list))
        (message "No operations specified.")
      ;; Confirm with the user.
      (when (or noquery
                (y-or-n-p (paradox--format-message 'question install-list delete-list)))
        ;; On Emacs 25, update the selected packages list.
        (when (fboundp 'package--update-selected-packages)
          (let-alist (package-menu--partition-transaction install-list delete-list)
            (package--update-selected-packages .install .delete)))
        ;; Background or foreground?
        (if (or (not install-list)
                (not (pcase paradox-execute-asynchronously
                       (`nil nil)
                       (`ask
                        (if noquery nil
                          (y-or-n-p "Execute in the background (see `paradox-execute-asynchronously')? ")))
                       (_ t))))
            ;; Synchronous execution
            (progn
              (let ((alist (paradox--perform-package-transaction install-list delete-list)))
                (run-hook-with-args 'paradox-after-execute-functions
                                    `((noquery . ,noquery) (async . nil) ,@alist)))
              (when (and (stringp paradox-github-token) paradox-automatically-star)
                (paradox--post-execute-star-unstar before-alist (paradox--repo-alist))))
          ;; Start spinning
          (paradox--start-spinner)
          
          ;; Async execution
          (unless (require 'async nil t)
            (error "For asynchronous execution please install the `async' package"))
          ;; We have to do this with eval, because `async-start' is a
          ;; macro and it might not have been defined at compile-time.
          (eval
           `(async-start
             (lambda ()
               (require 'package)
               ,(async-inject-variables "\\`package-")
               (setq package-menu-async nil)
               (dolist (elt package-alist)
                 (package-activate (car elt) 'force))
               (let ((alist ,(macroexpand
                              `(paradox--perform-package-transaction ',install-list ',delete-list))))
                 (list package-alist
                       (when (boundp 'package-selected-packages)
                         package-selected-packages)
                       package-archive-contents
                       ;; This is the alist that will be passed to the hook.
                       (cons '(noquery . ,noquery) (cons '(async . t) alist)))))
             (lambda (x)
               (setq package-alist (pop x)
                     package-selected-packages (pop x)
                     package-archive-contents (pop x))
               (when (spinner-p paradox--spinner)
                 (spinner-stop paradox--spinner)
                 (setq paradox--spinner nil))
               (setq paradox--executing nil)
               (run-hook-with-args 'paradox-after-execute-functions (pop x))
               (paradox--post-execute-star-unstar ',before-alist (paradox--repo-alist))))))))))


;;; Aux functions
(defun paradox--repo-alist ()
  "List of known repos."
  (delete-dups
   (remove nil
           (mapcar
            (lambda (it) (gethash it paradox--package-repo-list))
            package-alist))))

(defun paradox--format-message (question-p install-list delete-list)
  "Format a message regarding a transaction.
If QUESTION-P is non-nil, format a question suitable for
`y-or-n-p', otherwise format a report in the past sense.
INSTALL-LIST and DELETE-LIST are a list of packages about to be
installed and deleted, respectively."
  (concat
   (when install-list
     (let ((len (length install-list)))
       (format "Install%s %d package%s"
         (if question-p "" "ed")
         len
         (if (> len 1) "s" ""))))
   (when (and install-list (not delete-list))
     (if question-p "? " "."))
   (when (and install-list delete-list)
     ", and ")
   (when delete-list
     (let ((len (length delete-list)))
       (format "Delete%s %d package%s%s"
         (if question-p "" "d")
         len
         (if (> len 1) "s" "")
         (if question-p "? " "."))))))

(defun paradox--post-execute-star-unstar (before after)
  "Star repos in AFTER absent from BEFORE, unstar vice-versa."
  (let ((repos (hash-table-keys paradox--user-starred-repos)))
    (mapc #'paradox--star-repo
          (seq-difference (seq-difference after before) repos))
    (mapc #'paradox--unstar-repo
          (seq-intersection (seq-difference before after) repos))))

(provide 'paradox-execute)
;;; paradox-execute.el ends here