el-get-status.el

;;; el-get --- Manage the external elisp bits and pieces you depend upon
;;
;; Copyright (C) 2010-2011 Dimitri Fontaine
;;
;; Author: Dimitri Fontaine <dim@tapoueh.org>
;; URL: http://www.emacswiki.org/emacs/el-get
;; GIT: https://github.com/dimitri/el-get
;; Licence: WTFPL, grab your copy here: http://sam.zoy.org/wtfpl/
;;
;; This file is NOT part of GNU Emacs.
;;
;; Install
;;     Please see the README.md file from the same distribution

;;
;; package status --- a plist saved on a file, using symbols
;;
;; it should be possible to use strings instead, but in my tests it failed
;; miserably.
;;

(require 'cl-lib)
(require 'pp)
(require 'el-get-core)

(declare-function el-get-install "el-get" (package))
(declare-function el-get-package-is-installed "el-get" (package))
(declare-function el-get-print-package "el-get-list-packages" (package-name status &optional desc))

(defun el-get-package-name (package-symbol)
  "Returns a package name as a string."
  (cond ((keywordp package-symbol)
         (substring (symbol-name package-symbol) 1))
        ((symbolp package-symbol)
         (symbol-name package-symbol))
        ((stringp package-symbol)
         package-symbol)
        (t (error "Unknown package: %s" package-symbol))))

(defun el-get-package-symbol (package)
  "Returns a package name as a non-keyword symbol"
  (cond ((keywordp package)
         (intern (substring (symbol-name package) 1)))
        ((symbolp package)
         package)
        ((stringp package) (intern package))
        (t (error "Unknown package: %s" package))))

(defun el-get-package-keyword (package-name)
  "Returns a package name as a keyword :package."
  (if (keywordp package-name)
      package-name
    (intern (format ":%s" package-name))))

(defvar el-get-status-cache nil
  "Cache used by `el-get-read-status-file'.")

(defvar el-get-package-menu-buffer) ; from el-get-list-packages.el
(defun el-get-save-package-status (package status &optional recipe)
  "Save given package status"
  (let* ((package (el-get-as-symbol package))
         (recipe
          (or recipe
              (when (string= status "installed")
                (el-get-package-def package))))
         (package-status-alist
          (assq-delete-all package (el-get-read-status-file)))
         (new-package-status-alist
          (sort
           ;; Do not save package information if status is removed.
           (if (string= status "removed")
               package-status-alist
             (append package-status-alist
                     (list  ; alist of (PACKAGE . PROPERTIES-LIST)
                      (cons package (list 'status status 'recipe recipe)))))
           (lambda (p1 p2)
             (string< (el-get-as-string (car p1))
                      (el-get-as-string (car p2)))))))
    (cl-assert (listp recipe) nil
               "Recipe must be a list")
    (with-temp-file el-get-status-file
      (insert (el-get-print-to-string new-package-status-alist 'pretty)))
    ;; Update cache
    (setq el-get-status-cache new-package-status-alist)
    ;; Update package menu, if it exists
    (save-excursion
      (when (and (bound-and-true-p el-get-package-menu-buffer)
                 (buffer-live-p el-get-package-menu-buffer)
                 (set-buffer el-get-package-menu-buffer)
                 (eq major-mode 'el-get-package-menu-mode))
        (goto-char (point-min))
        (let ((inhibit-read-only t)
              (name (el-get-package-name package)))
          (when (re-search-forward
                 (format "^..%s[[:blank:]]+[^[:blank:]]+[[:blank:]]+"
                         (regexp-quote name)) nil t)
            (delete-region (match-beginning 0) (match-end 0))
            (el-get-print-package name status)))))
    ;; Return the new alist
    new-package-status-alist))

(defun el-get-convert-from-old-status-format (old-status-list)
  "Convert OLD-STATUS-LIST, a property list, to the new format"
  ;; first backup the old status just in case
  (with-temp-file (format "%s.old" el-get-status-file)
    (insert (el-get-print-to-string old-status-list)))
  ;; now convert to the new format, fetching recipes as we go
  (cl-loop for (p s) on old-status-list by 'cddr
           for psym = (el-get-package-symbol p)
           when psym
           collect
           (cons psym
                 (list 'status s
                       'recipe (when (string= s "installed")
                                 (condition-case nil
                                     (el-get-package-def psym)
                                   ;; If the recipe is not available any more,
                                   ;; just provide a placeholder no-op recipe.
                                   (error `(:name ,psym :type builtin))))))))

(defun el-get-clear-status-cache ()
  "Clear in-memory cache for status file."
  (setq el-get-status-cache nil))

(defun el-get-read-status-file ()
  "read `el-get-status-file' and return an alist of plist like:
   (PACKAGE . (status \"status\" recipe (:name ...)))"
  (or el-get-status-cache
      (setq el-get-status-cache (el-get-read-status-file-force))))

(defun el-get-read-status-file-force ()
  "Forcefully load status file."
  (let* ((ps
          (if (file-exists-p el-get-status-file)
              (car (with-temp-buffer
                     (insert-file-contents-literally el-get-status-file)
                     (read-from-string (buffer-string))))
            ;; If it doesn't exist, make sure the directory is there
            ;; so we can create it.
            (progn (make-directory el-get-dir t) nil)))
         (p-s
          (cond
           ((null ps) ;; nothing installed, we should install el-get
            (list (list 'el-get 'status "required")))
           ;; ps is an alist, no conversion needed
           ((consp (car ps)) ps)
           ;; looks like we might have an old format status list
           (t (el-get-convert-from-old-status-format ps)))))
    ;; double check some status "conditions"
    ;;
    ;; a package with status "installed" and a missing directory is
    ;; automatically reset to "required" so that a proper install happens.
    (cl-loop for (p . prop) in p-s
             if (and (string= (plist-get prop 'status) "installed")
                     (not (file-directory-p (el-get-package-directory p))))
             collect (cons p (plist-put prop 'status "required"))
             else
             collect (cons p prop))))

(defun el-get-package-status-alist ()
  "return an alist of (PACKAGE . STATUS)"
  (cl-loop for (p . prop) in (el-get-read-status-file)
           collect (cons p (plist-get prop 'status))))

(defun el-get-package-status-recipes ()
  "return the list of recipes stored in the status file"
  (cl-loop for (p . prop) in (el-get-read-status-file)
           when (string= (plist-get prop 'status) "installed")
           collect (plist-get prop 'recipe)))

(defun el-get-read-package-status (package)
  "return current status for PACKAGE"
  (plist-get (cdr (assq (el-get-as-symbol package) (el-get-read-status-file)))
             'status))

(define-obsolete-function-alias 'el-get-package-status 'el-get-read-package-status "4.1")

(defun el-get-read-package-status-recipe (package)
  "return current status recipe for PACKAGE"
  (plist-get (cdr (assq (el-get-as-symbol package) (el-get-read-status-file)))
             'recipe))

(defun el-get-filter-package-alist-with-status (package-status-alist &rest statuses)
  "Return package names that are currently in given status"
  (cl-loop for (p . prop) in package-status-alist
           for s = (plist-get prop 'status)
           when (member s statuses)
           collect (el-get-as-string p)))

(defun el-get-list-package-names-with-status (&rest statuses)
  "Return package names that are currently in given status"
  (apply #'el-get-filter-package-alist-with-status
         (el-get-read-status-file)
         statuses))

(defun el-get-read-package-with-status (action &rest statuses)
  "Read a package name in given status"
  (completing-read (format "%s package: " action)
                   (apply 'el-get-list-package-names-with-status statuses)))

(defun el-get-count-package-with-status (&rest statuses)
  "Return how many packages are currently in given status"
  (length (apply #'el-get-list-package-names-with-status statuses)))

(defun el-get-count-packages-with-status (packages &rest statuses)
  "Return how many packages are currently in given status in PACKAGES"
  (length (cl-intersection
           (mapcar #'el-get-as-symbol (apply #'el-get-list-package-names-with-status statuses))
           (mapcar #'el-get-as-symbol packages))))

(defun el-get-extra-packages (&rest packages)
  "Return installed or required packages that are not in given package list"
  (let ((packages
         ;; &rest could contain both symbols and lists
         (cl-loop for p in packages
                  when (listp p) append (mapcar 'el-get-as-symbol p)
                  else collect (el-get-as-symbol p))))
    (when packages
      (cl-loop for (p . prop) in (el-get-read-status-file)
               for s = (plist-get prop 'status)
               for x = (el-get-package-symbol p)
               unless (member x packages)
               unless (equal s "removed")
               collect (list x s)))))

(defmacro el-get-with-status-sources (_ &rest body)
  "Evaluate BODY with `el-get-sources' according to the status file."
  (declare (debug t) (indent 1))
  `(let ((el-get-sources (el-get-package-status-recipes)))
     (progn ,@body)))


(defconst el-get-status-init-whitelist
  '(:load-path
    :info
    :load
    :features
    :library
    :prepare
    :before
    :after
    :post-init
    :lazy
    :website
    :description)
  "Properties that can be updated with only `el-get-init'.

If any of these properties change on the recipe for an installed
package, the changes may be merged into the cached version of
that recipe in the el-get status file.")

(defconst el-get-status-update-whitelist
  `(:depends
    :build
    ;; :build/* ; special cased below
    :compile
    :checksum
    :checkout
    :options
    ,@el-get-status-init-whitelist)
  "Properties than can be updated by `el-get-update'.")

(defun el-get-classify-new-properties (source newprops)
  "Determine the operations required to update SOURCE with NEWPROPS.

Partition the properties of NEWPROPS whose value is different
from SOURCE into 3 sublists, (INIT UPDATE REINSTALL), according
to the operation required."
  (cl-loop with init and update and reinstall
           with type = (let ((old-type (el-get-package-method source))
                             (new-type (el-get-package-method newprops)))
                         (if (eq old-type new-type) old-type nil))
           for (k v) on newprops by 'cddr
           if (equal v (plist-get source k)) do (ignore) ; Ignore non-changes.
           else if
           (or (memq k el-get-status-init-whitelist)
               (if (eq k :builtin) ; `:builtin' safe if not crossing versions.
                   (eq (version<= emacs-version (el-get-as-string v))
                       (version<= emacs-version (el-get-as-string
                                                 (plist-get source k))))))
           do (setq init (plist-put init k v))
           else if (or (memq k el-get-status-update-whitelist)
                       ;; All `:build/*' props are update safe, like `:build'.
                       (string-prefix-p ":build/" (symbol-name k))
                       (if (eq k :url) ; `:http*' methods can handle `:url' changes.
                           (memq type '(http http-tar http-zip
                                             github-tar github-zip
                                             builtin))))
           do (setq update (plist-put update k v))
           else do (setq reinstall (plist-put reinstall k v))
           finally return (list init update reinstall)))

(defun el-get-diagnosis-properties (old-source new-source)
  "Diagnosis difference between OLD-SOURCE and NEW-SOURCE.

Return a list (REQUIRED-OPS ADDED REMOVED).  REQUIRED-OPS is list
of one or more of `init', `update', or `reinstall' when
OLD-SOURCE and NEW-SOURCE are different (nil otherwise).  It
indicates which operations can perform the change.  ADDED and
REMOVED are added and removed properties, respectively."
  (let* ((added   (el-get-classify-new-properties old-source new-source))
         (removed (el-get-classify-new-properties new-source old-source))
         (min-op  (cond ((or (nth 2 added) (nth 2 removed)) 2)
                        ((or (nth 1 added) (nth 1 removed)) 1)
                        ((or (nth 0 added) (nth 0 removed)) 0))))
    (list (and min-op (nthcdr min-op '(init update reinstall)))
          (apply #'append (nthcdr (or min-op 0) added))
          (apply #'append (nthcdr (or min-op 0) removed)))))

(defun el-get-package-or-source (package-or-source)
  "Given either a package name or a full source entry, return a
   full source entry."
  (if (listp package-or-source)
      (or package-or-source
          (error "package-or-source cannot be nil"))
    (el-get-package-def package-or-source)))

(defun el-get-read-cached-recipe (package source)
  "Read the cached recipe for given PACKAGE: the one we have in the status file.

   If given PACKAGE isn't registered in the status file, and if
   it's a builtin package, then install it."
  (or (el-get-read-package-status-recipe package)
      (if (eq 'builtin (el-get-package-method source))
          (let ((el-get-default-process-sync t))
            (el-get-install package))
        ;; it's not builtin, it's not installed.
        (error "Package %s is nowhere to be found in el-get status file."
               package))))

(defun el-get-merge-properties-into-status (package-or-source
                                            operation
                                            &rest keys)
  "Merge updatable properties for package into package status
alist (or status file).

The first argument is either a package source or a package name,
in which case the source will be read using
`el-get-package-def'. The named package must already be
installed.

If the new source differs only in whitelisted properties (see
`el-get-status-recipe-updatable-properties'), then the updated
values for those properties will be written to the status
file.

If any non-whitelisted properties differ from the cached values,
then an error is raise. With optional keyword argument `:noerror
t', this error is suppressed (but nothing is updated).

\(fn PACKAGE-OR-SOURCE &key NOERROR)"
  (interactive
   (list (el-get-read-package-with-status "Update cached recipe" "installed")
         'init
         :noerror current-prefix-arg))
  (let* ((noerror      (cadr (memq :noerror keys)))
         (source       (el-get-package-or-source package-or-source))
         (package      (el-get-as-symbol (el-get-source-name source)))
         (cached-recipe
          (el-get-read-cached-recipe package source)))
    (unless (el-get-package-is-installed package)
      (error "Package %s is not installed. Cannot update recipe." package))
    (cl-destructuring-bind (required-ops added removed)
        (el-get-diagnosis-properties cached-recipe source)
      (if (and required-ops (not (memq operation required-ops)))
        ;; Emit a verbose message if `noerror' is t (but still quit
        ;; the function).
        (funcall (if noerror 'el-get-verbose-message 'error)
                 (concat "Must %s `%s' to modify its cached recipe\n"
                         "  adding:   %s"
                         "  removing: %s")
                 (mapconcat #'symbol-name required-ops " or ") package
                 (if   added (pp-to-string   added) "()\n")
                 (if removed (pp-to-string removed) "()\n"))
      (when required-ops
        (el-get-save-package-status package "installed" source))))))

(provide 'el-get-status)