864 lines
39 KiB
EmacsLisp
864 lines
39 KiB
EmacsLisp
;;; core-configuration-layer.el --- Spacemacs Core File
|
|
;;
|
|
;; Copyright (c) 2012-2014 Sylvain Benner
|
|
;; Copyright (c) 2014-2015 Sylvain Benner & Contributors
|
|
;;
|
|
;; Author: Sylvain Benner <sylvain.benner@gmail.com>
|
|
;; URL: https://github.com/syl20bnr/spacemacs
|
|
;;
|
|
;; This file is not part of GNU Emacs.
|
|
;;
|
|
;;; License: GPLv3
|
|
(require 'ht)
|
|
(require 'package)
|
|
(require 'core-dotspacemacs)
|
|
(require 'core-funcs)
|
|
(require 'core-spacemacs-buffer)
|
|
|
|
(unless package--initialized
|
|
(setq package-archives '(("ELPA" . "http://tromey.com/elpa/")
|
|
("gnu" . "http://elpa.gnu.org/packages/")
|
|
("melpa" . "http://melpa.org/packages/")))
|
|
;; optimization, no need to activate all the packages so early
|
|
(setq package-enable-at-startup nil)
|
|
(package-initialize 'noactivate)
|
|
;; Emacs 24.3 and above ships with python.el but in some Emacs 24.3.1 packages
|
|
;; for Ubuntu, python.el seems to be missing.
|
|
;; This hack adds marmalade repository for this case only.
|
|
(unless (or (package-installed-p 'python) (version< emacs-version "24.3"))
|
|
(add-to-list 'package-archives
|
|
'("marmalade" . "http://marmalade-repo.org/packages/")))
|
|
(setq warning-minimum-level :error))
|
|
|
|
(defconst configuration-layer-template-directory
|
|
(expand-file-name (concat spacemacs-core-directory "templates/"))
|
|
"Configuration layer templates directory.")
|
|
|
|
(defconst configuration-layer-contrib-directory
|
|
(expand-file-name (concat user-emacs-directory "contrib/"))
|
|
"Spacemacs contribution layers base directory.")
|
|
|
|
(defconst configuration-layer-private-directory
|
|
(expand-file-name (concat user-emacs-directory "private/"))
|
|
"Spacemacs private layers base directory.")
|
|
|
|
(defconst configuration-layer-rollback-directory
|
|
(expand-file-name (concat spacemacs-cache-directory ".rollback/"))
|
|
"Spacemacs rollback directory.")
|
|
|
|
(defconst configuration-layer-rollback-info "rollback-info"
|
|
"Spacemacs rollback information file.")
|
|
|
|
(defvar configuration-layer-error-count nil
|
|
"Non nil indicates the number of errors occurred during the
|
|
installation of initialization.")
|
|
|
|
(defvar configuration-layer-layers '()
|
|
"Alist of declared configuration layers.")
|
|
|
|
(defvar configuration-layer-paths (make-hash-table :size 256)
|
|
"Hash table of layers locations. The key is a layer symbol and the value is
|
|
the path for this layer.")
|
|
|
|
(defvar configuration-layer-all-packages (make-hash-table :size 512)
|
|
"Hash table of all declared packages in all layers where the key is a package
|
|
symbol and the value is a list of layer symbols responsible for initializing
|
|
and configuring the package.")
|
|
|
|
(defvar configuration-layer-all-packages-sorted '()
|
|
"Sorted list of all package symbols.")
|
|
|
|
(defvar configuration-layer-packages-init-funcs '(make-hash-table :size 512)
|
|
"Hash table of packages initialization functions. The key is a package symbol
|
|
and the value is an odered list of initialization functions to execute.")
|
|
|
|
(defvar configuration-layer-all-pre-extensions (make-hash-table :size 256)
|
|
"Hash table of all declared pre-extensions in all layers where the key is a
|
|
extension symbol and the value is the layer symbols responsible for initializing
|
|
and configuring the package.")
|
|
|
|
(defvar configuration-layer-all-pre-extensions-sorted '()
|
|
"Sorted list of all pre extensions symbols.")
|
|
|
|
(defvar configuration-layer-pre-extensions-init-funcs '(make-hash-table :size 256)
|
|
"Hash table of pre-extensions initialization functions. The key is a package
|
|
symbol and the value is an odered list of initialization functions to execute.")
|
|
|
|
(defvar configuration-layer-all-post-extensions (make-hash-table :size 256)
|
|
"Hash table of all declared post-extensions in all layers where the key is a
|
|
extension symbol and the value is the layer symbols responsible for initializing
|
|
and configuring the package.")
|
|
|
|
(defvar configuration-layer-post-extensions-init-funcs '(make-hash-table :size 256)
|
|
"Hash table of post-extensions initialization functions. The key is a package
|
|
symbol and the value is an odered list of initialization functions to execute.")
|
|
|
|
(defvar configuration-layer-all-post-extensions-sorted '()
|
|
"Sorted list of all post extensions symbols.")
|
|
|
|
(defvar configuration-layer-contrib-categories '("config"
|
|
"fun"
|
|
"irc"
|
|
"lang"
|
|
"usr")
|
|
"List of strings corresponding to category names. A category is a
|
|
sub-directory of the contribution directory.")
|
|
|
|
(defvar configuration-layer-excluded-packages '()
|
|
"List of all excluded packages declared at the layer level.")
|
|
|
|
(defun configuration-layer/sync ()
|
|
"Synchronize declared layers in dotfile with spacemacs."
|
|
(dotspacemacs|call-func dotspacemacs/layers "Calling dotfile layers...")
|
|
(configuration-layer/init-layers)
|
|
(configuration-layer/load-layers)
|
|
(when dotspacemacs-delete-orphan-packages
|
|
(configuration-layer/delete-orphan-packages)))
|
|
|
|
(defun configuration-layer/create-layer (name)
|
|
"Ask the user for a configuration layer name and create a layer with this
|
|
name in the private layers directory."
|
|
(interactive "sConfiguration layer name: ")
|
|
(let ((layer-dir (configuration-layer//get-private-layer-dir name)))
|
|
(cond
|
|
((string-equal "" name)
|
|
(message "Cannot create a configuration layer without a name."))
|
|
((file-exists-p layer-dir)
|
|
(message "Cannot create configuration layer \"%s\", this layer already exists."
|
|
name))
|
|
(t
|
|
(make-directory layer-dir)
|
|
(configuration-layer//copy-template "extensions")
|
|
(configuration-layer//copy-template "packages")
|
|
(message "Configuration layer \"%s\" successfully created." name))
|
|
)))
|
|
|
|
(defun configuration-layer//get-private-layer-dir (name)
|
|
"Return an absolute path the the private configuration layer with name
|
|
NAME."
|
|
(concat configuration-layer-private-directory name "/"))
|
|
|
|
(defun configuration-layer//copy-template (template)
|
|
"Copy and replace special values of TEMPLATE to LAYER_DIR."
|
|
(let ((src (concat configuration-layer-template-directory
|
|
(format "%s.template" template)))
|
|
(dest (concat (configuration-layer//get-private-layer-dir name)
|
|
(format "%s.el" template))))
|
|
(copy-file src dest)
|
|
(find-file dest)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(while (re-search-forward "NAME" nil t)
|
|
(replace-match name t)))
|
|
(save-buffer)))
|
|
|
|
(defun configuration-layer//get-contrib-category-dirs ()
|
|
"Return a list of all absolute paths to the contribution categories stored
|
|
in `configuration-layer-contrib-categories'"
|
|
(mapcar
|
|
(lambda (d) (expand-file-name
|
|
(concat configuration-layer-contrib-directory (format "%s/" d))))
|
|
configuration-layer-contrib-categories))
|
|
|
|
(defun configuration-layer//discover-layers ()
|
|
"Return a hash table where the key is the layer symbol and the value is its
|
|
path."
|
|
(let ((cat-dirs (configuration-layer//get-contrib-category-dirs))
|
|
(result (make-hash-table :size 256)))
|
|
;; add spacemacs layer
|
|
(puthash 'spacemacs (expand-file-name user-emacs-directory) result)
|
|
(mapc (lambda (dir)
|
|
(let ((layers (configuration-layer//discover-layers-in-dir dir)))
|
|
(mapc (lambda (layer)
|
|
(puthash (car layer) (cdr layer) result))
|
|
layers)))
|
|
(append (list configuration-layer-contrib-directory)
|
|
cat-dirs
|
|
dotspacemacs-configuration-layer-path
|
|
;; load private layers at the end on purpose
|
|
;; we asume that the user layers must have the final word
|
|
;; on configuration choices.
|
|
(list configuration-layer-private-directory)))
|
|
result))
|
|
|
|
(defun configuration-layer//discover-layers-in-dir (dir)
|
|
"Return an alist where the key is a layer symbol and the value is the path
|
|
for that layer."
|
|
(spacemacs/message "Looking for configuration layers in %s" dir)
|
|
(ignore-errors
|
|
(let ((files (directory-files dir nil nil 'nosort))
|
|
(filter-out configuration-layer-contrib-categories)
|
|
result '())
|
|
(dolist (f files)
|
|
(when (and (file-directory-p (concat dir f))
|
|
(not (member f filter-out))
|
|
(not (equalp ?. (aref f 0)))) ;; Remove hidden, traversal
|
|
(spacemacs/message "-> Discovered configuration layer: %s" f)
|
|
(push (cons (intern f) dir) result)))
|
|
result)))
|
|
|
|
(defun configuration-layer/init-layers ()
|
|
"Declare default layers and user layers from the dotfile by filling the
|
|
`configuration-layer-layers' variable."
|
|
(setq configuration-layer-paths (configuration-layer//discover-layers))
|
|
(if (eq 'all dotspacemacs-configuration-layers)
|
|
(setq dotspacemacs-configuration-layers
|
|
;; spacemacs is contained in configuration-layer-paths
|
|
(ht-keys configuration-layer-paths))
|
|
(setq configuration-layer-layers
|
|
(list (configuration-layer//declare-layer 'spacemacs))))
|
|
(setq configuration-layer-layers
|
|
(append (configuration-layer//declare-layers
|
|
dotspacemacs-configuration-layers) configuration-layer-layers)))
|
|
|
|
(defun configuration-layer//declare-layers (layers)
|
|
"Declare the passed configuration LAYERS.
|
|
LAYERS is a list of layer symbols."
|
|
(reduce (lambda (acc elt) (push elt acc))
|
|
(mapcar 'configuration-layer//declare-layer (reverse layers))
|
|
:initial-value nil))
|
|
|
|
(defun configuration-layer//declare-layer (layer)
|
|
"Declare a layer with NAME symbol. Return a cons cell (symbol . plist)
|
|
where `symbol' is the name of the layer and `plist' is a property list with
|
|
the following keys:
|
|
- `:dir' the absolute path to the base directory of the layer.
|
|
- `:ext-dir' the absolute path to the directory containing the extensions.
|
|
- `:variables' list of layer configuration variables to set
|
|
- `:excluded' list of packages to exlcude."
|
|
(let* ((name-sym (if (listp layer) (car layer) layer))
|
|
(name-str (symbol-name name-sym))
|
|
(base-dir (configuration-layer/get-layer-path name-sym)))
|
|
(if base-dir
|
|
(let* ((dir (format "%s%s/" base-dir name-str))
|
|
(ext-dir (format "%sextensions/" dir))
|
|
(plist (append (list :dir dir :ext-dir ext-dir)
|
|
(when (listp layer) (cdr layer)))))
|
|
(cons name-sym plist))
|
|
(spacemacs/message "Warning: Cannot find layer %S !" name-sym)
|
|
nil)))
|
|
|
|
(defun configuration-layer//set-layers-variables (layers)
|
|
"Set the configuration variables for the passed LAYERS."
|
|
(dolist (layer layers)
|
|
(let ((variables (spacemacs/mplist-get layer :variables)))
|
|
(while variables
|
|
(let ((var (pop variables)))
|
|
(if (consp variables)
|
|
(set-default var (pop variables))
|
|
(spacemacs/message "Warning: Missing value for variable %s !"
|
|
var)))))))
|
|
|
|
(defun configuration-layer/package-usedp (pkg)
|
|
"Return non-nil if PKG symbol corresponds to a used package."
|
|
(ht-contains? configuration-layer-all-packages pkg))
|
|
|
|
(defun configuration-layer/layer-usedp (layer)
|
|
"Return non-nil if LAYER symbol corresponds to a used layer."
|
|
(not (null (assq layer configuration-layer-layers))))
|
|
|
|
(defun configuration-layer/get-layers-list ()
|
|
"Return a list of all discovered layer symbols."
|
|
(ht-keys configuration-layer-paths))
|
|
|
|
(defun configuration-layer/get-layer-path (layer)
|
|
"Return the path for LAYER symbol."
|
|
(ht-get configuration-layer-paths layer))
|
|
|
|
(defun configuration-layer/load-layers ()
|
|
"Load all declared layers."
|
|
(let ((layers (reverse configuration-layer-layers)))
|
|
(configuration-layer//set-layers-variables layers)
|
|
;; first load the config files then the package files
|
|
(configuration-layer//load-layers-files layers '("funcs.el" "config.el"))
|
|
(configuration-layer//load-layers-files layers '("packages.el" "extensions.el"))
|
|
;; fill the hash tables
|
|
(setq configuration-layer-all-packages (configuration-layer/get-packages layers))
|
|
(setq configuration-layer-excluded-packages (configuration-layer/get-excluded-packages layers))
|
|
(setq configuration-layer-all-pre-extensions (configuration-layer/get-extensions layers t))
|
|
(setq configuration-layer-all-post-extensions (configuration-layer/get-extensions layers))
|
|
;; This is what you get when you have no test cases... hopefully I will code
|
|
;; them soon :-)
|
|
;; (message "excluded: %s" configuration-layer-excluded-packages)
|
|
;; (message "packages: %s" configuration-layer-all-packages)
|
|
;; (message "pre-extensions: %s" configuration-layer-all-pre-extensions)
|
|
;; (message "post-extensions: %s" configuration-layer-all-post-extensions)
|
|
;; filter them
|
|
(let ((excluded (append dotspacemacs-excluded-packages
|
|
configuration-layer-excluded-packages)))
|
|
(configuration-layer//filter-out-excluded configuration-layer-all-packages excluded)
|
|
(configuration-layer//filter-out-excluded configuration-layer-all-pre-extensions excluded)
|
|
(configuration-layer//filter-out-excluded configuration-layer-all-post-extensions excluded))
|
|
(setq configuration-layer-packages-init-funcs
|
|
(configuration-layer//filter-init-funcs configuration-layer-all-packages))
|
|
(setq configuration-layer-pre-extensions-init-funcs
|
|
(configuration-layer//filter-init-funcs configuration-layer-all-pre-extensions t))
|
|
(setq configuration-layer-post-extensions-init-funcs
|
|
(configuration-layer//filter-init-funcs configuration-layer-all-post-extensions t))
|
|
;; (message "package init-funcs: %s" configuration-layer-packages-init-funcs)
|
|
;; number of chuncks for the loading screen
|
|
(let ((total (+ (ht-size configuration-layer-all-packages)
|
|
(ht-size configuration-layer-all-pre-extensions)
|
|
(ht-size configuration-layer-all-post-extensions))))
|
|
(setq spacemacs-loading-dots-chunk-threshold
|
|
(/ total spacemacs-loading-dots-chunk-count)))
|
|
;; sort packages before initializing them
|
|
(configuration-layer//sort-packages-and-extensions)
|
|
;; install and initialize packages and extensions
|
|
(configuration-layer//initialize-pre-extensions)
|
|
(configuration-layer//install-packages)
|
|
(configuration-layer//initialize-packages)
|
|
(configuration-layer//initialize-post-extensions)
|
|
;; restore warning level before initialization
|
|
(setq warning-minimum-level :warning)
|
|
(configuration-layer//load-layers-files layers '("keybindings.el"))))
|
|
|
|
(defun configuration-layer//load-layers-files (layers files)
|
|
"Load the files of list FILES for all passed LAYERS."
|
|
(dolist (layer layers)
|
|
(configuration-layer//load-layer-files layer files)))
|
|
|
|
(defun configuration-layer//load-layer-files (layer files)
|
|
"Load the files of list FILES for the given LAYER."
|
|
(let* ((sym (car layer))
|
|
(dir (plist-get (cdr layer) :dir)))
|
|
(dolist (file files)
|
|
(let ((file (concat dir file)))
|
|
(if (file-exists-p file) (load file))))))
|
|
|
|
(defsubst configuration-layer//add-layer-to-hash (pkg layer hash)
|
|
"Add LAYER to the list value stored in HASH with key PKG."
|
|
(let ((list (ht-get hash pkg)))
|
|
(eval `(push ',layer list))
|
|
(puthash pkg list hash)))
|
|
|
|
(defun configuration-layer//filter-out-excluded (hash excluded)
|
|
"Remove EXCLUDED packages from the hash tables HASH."
|
|
(dolist (pkg (ht-keys hash))
|
|
(when (or (member pkg excluded)) (ht-remove hash pkg))))
|
|
|
|
(defun configuration-layer//filter-init-funcs (hash &optional extension-p)
|
|
"Remove from HASH packages with no corresponding initialization function and
|
|
returns a hash table of package symbols mapping to a list of initialization
|
|
functions to execute."
|
|
(let ((result (make-hash-table :size 512)))
|
|
(dolist (pkg (ht-keys hash))
|
|
(let (initlayer prefuncs initfuncs postfuncs)
|
|
(dolist (layer (ht-get hash pkg))
|
|
(let ((initf (intern (format "%s/init-%S" layer pkg)))
|
|
(pref (intern (format "%s/pre-init-%S" layer pkg)))
|
|
(postf (intern (format "%s/post-init-%S" layer pkg))))
|
|
(when (fboundp initf)
|
|
(setq initlayer layer)
|
|
(push initf initfuncs))
|
|
(when (fboundp pref) (push pref prefuncs))
|
|
(when (fboundp postf) (push postf postfuncs))))
|
|
(if initfuncs
|
|
(progn
|
|
(puthash pkg (append prefuncs initfuncs postfuncs) result)
|
|
(when extension-p
|
|
(push (format "%s%s/"
|
|
(configuration-layer/get-layer-property
|
|
initlayer :ext-dir) pkg)
|
|
load-path)))
|
|
(spacemacs/message
|
|
(format "%s %S is ignored since it has no init function."
|
|
(if extension-p "Extension" "Package") pkg))
|
|
(ht-remove hash pkg))))
|
|
result))
|
|
|
|
(defun configuration-layer//sort-packages-and-extensions ()
|
|
"Sort the packages and extensions symbol and store them in
|
|
`configuration-layer-all-packages-sorted'
|
|
`configuration-layer-all-pre-extensions-sorted'
|
|
`configuration-layer-all-post-extensions-sorted'"
|
|
(setq configuration-layer-all-packages-sorted
|
|
(configuration-layer/sort-hash-table-keys configuration-layer-all-packages))
|
|
(setq configuration-layer-all-pre-extensions-sorted
|
|
(configuration-layer/sort-hash-table-keys configuration-layer-all-pre-extensions))
|
|
(setq configuration-layer-all-post-extensions-sorted
|
|
(configuration-layer/sort-hash-table-keys configuration-layer-all-post-extensions)))
|
|
|
|
(defun configuration-layer/sort-hash-table-keys (h)
|
|
"Return a sorted list of the keys in the given hash table H."
|
|
(mapcar 'intern (sort (mapcar 'symbol-name (ht-keys h)) 'string<)))
|
|
|
|
(defun configuration-layer/get-excluded-packages (layers)
|
|
"Read `layer-excluded-packages' lists for all passed LAYERS and return a list
|
|
of all excluded packages."
|
|
(let (result)
|
|
(dolist (layer layers)
|
|
(let* ((layer-sym (car layer))
|
|
(excl-var (intern (format "%s-excluded-packages"
|
|
(symbol-name layer-sym)))))
|
|
(when (boundp excl-var)
|
|
(mapc (lambda (x) (push x result)) (eval excl-var)))))
|
|
result))
|
|
|
|
(defun configuration-layer//get-packages-or-extensions (layers file var)
|
|
"Read the packages or extensions lists for all passed LAYERS and
|
|
return a hash table of all packages where the key is a package symbol.
|
|
|
|
FILE is a string with value `packages' or `extensions'.
|
|
VAR is a string with value `packages', `pre-extensions' or `post-extensions'."
|
|
(let ((result (make-hash-table :size 512)))
|
|
(dolist (layer layers)
|
|
(let* ((layer-sym (car layer))
|
|
(dir (plist-get (cdr layer) :dir))
|
|
(pkg-file (concat dir (format "%s.el" file))))
|
|
(when (file-exists-p pkg-file)
|
|
(unless (configuration-layer/layer-usedp layer-sym)
|
|
(load pkg-file))
|
|
(let* ((layer-name (symbol-name layer-sym))
|
|
(packages-var (intern (format "%s-%s" layer-name var))))
|
|
(when (boundp packages-var)
|
|
(dolist (pkg (eval packages-var))
|
|
(puthash pkg (cons layer-sym (ht-get result pkg)) result)))))))
|
|
result))
|
|
|
|
(defun configuration-layer/get-packages (layers)
|
|
"Read `layer-packages' lists for all passed LAYERS and return a hash table
|
|
of all packages where the key is a package symbol."
|
|
(configuration-layer//get-packages-or-extensions layers "packages" "packages"))
|
|
|
|
(defun configuration-layer/get-extensions (layers &optional pre)
|
|
"Read `layer-pre-extensions' or `layer-post-extensions' lists for all passed
|
|
LAYERS and return a hash table of all packages where the key is a package
|
|
symbol.
|
|
If PRE is non nil then `layer-pre-extensions' is read instead of
|
|
`layer-post-extensions'."
|
|
(let ((var (if pre "pre-extensions" "post-extensions")))
|
|
(configuration-layer//get-packages-or-extensions layers "extensions" var)))
|
|
|
|
(defun configuration-layer//install-packages ()
|
|
"Install the packages all the packages if there are not currently installed."
|
|
(interactive)
|
|
(let* ((not-installed (configuration-layer//get-packages-to-install
|
|
configuration-layer-all-packages-sorted))
|
|
(not-installed-count (length not-installed)))
|
|
;; installation
|
|
(if not-installed
|
|
(progn
|
|
(spacemacs/append-to-buffer
|
|
(format "Found %s new package(s) to install...\n"
|
|
not-installed-count))
|
|
(spacemacs/append-to-buffer
|
|
"--> fetching new package repository indexes...\n")
|
|
(spacemacs//redisplay)
|
|
(package-refresh-contents)
|
|
(setq installed-count 0)
|
|
(dolist (pkg not-installed)
|
|
(setq installed-count (1+ installed-count))
|
|
(let ((layer (ht-get configuration-layer-all-packages pkg)))
|
|
(spacemacs/replace-last-line-of-buffer
|
|
(format "--> installing %s%s... [%s/%s]"
|
|
(if layer (format "%s:" layer) "")
|
|
pkg installed-count not-installed-count) t))
|
|
(unless (package-installed-p pkg)
|
|
(condition-case err
|
|
(if (not (assq pkg package-archive-contents))
|
|
(spacemacs/append-to-buffer
|
|
(format "\nPackage %s is unavailable. Is the package name misspelled?\n"
|
|
pkg))
|
|
(dolist (dep (configuration-layer//get-package-dependencies-from-archive
|
|
pkg))
|
|
(configuration-layer//activate-package (car dep)))
|
|
(package-install pkg))
|
|
('error
|
|
(configuration-layer//set-error)
|
|
(spacemacs/append-to-buffer
|
|
(format (concat "An error occurred while installing %s "
|
|
"(error: %s)\n") pkg err)))))
|
|
(spacemacs//redisplay))
|
|
(spacemacs/append-to-buffer "\n")))))
|
|
|
|
(defun configuration-layer//filter-packages-with-deps (packages filter)
|
|
"Filter a PACKAGES list according to a FILTER predicate.
|
|
|
|
FILTER is a function applied to each element of PACKAGES, if FILTER returns
|
|
non nil then element is removed from the list otherwise element is kept in
|
|
the list.
|
|
|
|
This function also processed recursively the package dependencies."
|
|
(when packages
|
|
(let (result)
|
|
(dolist (pkg packages)
|
|
;; recursively check dependencies
|
|
(let* ((deps
|
|
(configuration-layer//get-package-dependencies-from-archive pkg))
|
|
(install-deps
|
|
(when deps (configuration-layer//filter-packages-with-deps
|
|
(mapcar 'car deps) filter))))
|
|
(when install-deps
|
|
(setq result (append install-deps result))))
|
|
(unless (apply filter `(,pkg))
|
|
(add-to-list 'result pkg t)))
|
|
(delete-dups result))))
|
|
|
|
(defun configuration-layer//get-packages-to-install (packages)
|
|
"Return a list of packages to install given a list of PACKAGES."
|
|
(configuration-layer//filter-packages-with-deps
|
|
packages
|
|
(lambda (x)
|
|
;; the package is already installed
|
|
(package-installed-p x))))
|
|
|
|
(defun configuration-layer//get-packages-to-update (packages)
|
|
"Return a list of packages to update given a list of PACKAGES."
|
|
(configuration-layer//filter-packages-with-deps
|
|
packages
|
|
(lambda (x)
|
|
;; the package is a built-in package
|
|
;; or a newest version is available
|
|
(let ((installed-ver (configuration-layer//get-package-version-string x)))
|
|
(or (null installed-ver)
|
|
(version<= (configuration-layer//get-latest-package-version-string x)
|
|
installed-ver))))))
|
|
|
|
(defun configuration-layer/update-packages ()
|
|
"Upgrade elpa packages"
|
|
(interactive)
|
|
(spacemacs/insert-page-break)
|
|
(spacemacs/append-to-buffer
|
|
"\nUpdating Spacemacs... (for now only ELPA packages are updated)\n")
|
|
(spacemacs/append-to-buffer
|
|
"--> fetching new package repository indexes...\n")
|
|
(spacemacs//redisplay)
|
|
(package-refresh-contents)
|
|
(let* ((update-packages (configuration-layer//get-packages-to-update
|
|
configuration-layer-all-packages-sorted))
|
|
(date (format-time-string "%y-%m-%d_%H.%M.%S"))
|
|
(rollback-dir (expand-file-name
|
|
(concat configuration-layer-rollback-directory
|
|
(file-name-as-directory date))))
|
|
(upgrade-count (length update-packages))
|
|
(upgraded-count 0)
|
|
(update-packages-alist))
|
|
(if (> upgrade-count 0)
|
|
(if (not (yes-or-no-p (format (concat "%s package(s) to update, "
|
|
"do you want to continue ? ")
|
|
upgrade-count)))
|
|
(spacemacs/append-to-buffer
|
|
"Packages update has been cancelled.\n")
|
|
;; backup the package directory and construct an alist
|
|
;; variable to be cached for easy update and rollback
|
|
(spacemacs/append-to-buffer
|
|
"--> performing backup of package(s) to update...\n" t)
|
|
(spacemacs//redisplay)
|
|
(dolist (pkg update-packages)
|
|
(let* ((src-dir (configuration-layer//get-package-directory pkg))
|
|
(dest-dir (expand-file-name
|
|
(concat rollback-dir
|
|
(file-name-as-directory
|
|
(file-name-nondirectory src-dir))))))
|
|
(copy-directory src-dir dest-dir 'keeptime 'create 'copy-content)
|
|
(push (cons pkg (file-name-nondirectory src-dir))
|
|
update-packages-alist)))
|
|
(spacemacs/dump-vars-to-file
|
|
'(update-packages-alist)
|
|
(expand-file-name (concat rollback-dir
|
|
configuration-layer-rollback-info)))
|
|
(dolist (pkg update-packages)
|
|
(setq upgraded-count (1+ upgraded-count))
|
|
(spacemacs/replace-last-line-of-buffer
|
|
(format "--> preparing update of package %s... [%s/%s]"
|
|
pkg upgraded-count upgrade-count) t)
|
|
(spacemacs//redisplay)
|
|
(configuration-layer//package-delete pkg))
|
|
(spacemacs/append-to-buffer
|
|
(format "\n--> %s package(s) to be updated.\n" upgraded-count))
|
|
(spacemacs/append-to-buffer
|
|
"\nEmacs has to be restarted to actually install the new packages.\n")
|
|
(spacemacs//redisplay))
|
|
(spacemacs/append-to-buffer "--> All packages are up to date.\n")
|
|
(spacemacs//redisplay))))
|
|
|
|
(defun configuration-layer//ido-candidate-rollback-slot ()
|
|
"Return a list of candidates to select a rollback slot."
|
|
(let ((rolldir configuration-layer-rollback-directory))
|
|
(when (file-exists-p rolldir)
|
|
(reverse
|
|
(delq nil (mapcar
|
|
(lambda (x)
|
|
(when (not (or (string= "." x) (string= ".." x)))
|
|
(let ((p (length (directory-files (file-name-as-directory
|
|
(concat rolldir x))))))
|
|
;; -3 for . .. and rollback-info
|
|
(format "%s (%s packages)" x (- p 3)))))
|
|
(directory-files rolldir)))))))
|
|
|
|
(defun configuration-layer/rollback (slot)
|
|
"Rollback all the packages in the given SLOT.
|
|
If called interactively and SLOT is nil then an ido buffers appears
|
|
to select one."
|
|
(interactive
|
|
(list
|
|
(if (boundp 'slot) slot
|
|
(let ((candidates (configuration-layer//ido-candidate-rollback-slot)))
|
|
(when candidates
|
|
(ido-completing-read "Rollback slots (most recent are first): "
|
|
candidates))))))
|
|
(spacemacs/insert-page-break)
|
|
(if (not slot)
|
|
(message "No rollback slot available.")
|
|
(string-match "^\\(.+?\\)\s.*$" slot)
|
|
(let* ((slot-dir (match-string 1 slot))
|
|
(rollback-dir (file-name-as-directory
|
|
(concat configuration-layer-rollback-directory
|
|
(file-name-as-directory slot-dir))))
|
|
(info-file (expand-file-name
|
|
(concat rollback-dir
|
|
configuration-layer-rollback-info))))
|
|
(spacemacs/append-to-buffer
|
|
(format "\nRollbacking ELPA packages from slot %s...\n" slot-dir))
|
|
(load-file info-file)
|
|
(let ((rollback-count (length update-packages-alist))
|
|
(rollbacked-count 0))
|
|
(spacemacs/append-to-buffer
|
|
(format "Found %s package(s) to rollback...\n" rollback-count))
|
|
(spacemacs//redisplay)
|
|
(dolist (apkg update-packages-alist)
|
|
(let* ((pkg (car apkg))
|
|
(pkg-dir-name (cdr apkg))
|
|
(installed-ver
|
|
(configuration-layer//get-package-version-string pkg))
|
|
(elpa-dir (concat user-emacs-directory "elpa/"))
|
|
(src-dir (expand-file-name
|
|
(concat rollback-dir (file-name-as-directory
|
|
pkg-dir-name))))
|
|
(dest-dir (expand-file-name
|
|
(concat elpa-dir (file-name-as-directory
|
|
pkg-dir-name)))))
|
|
(setq rollbacked-count (1+ rollbacked-count))
|
|
(if (string-equal (format "%S-%s" pkg installed-ver) pkg-dir-name)
|
|
(spacemacs/replace-last-line-of-buffer
|
|
(format "--> package %s already rollbacked! [%s/%s]"
|
|
pkg rollbacked-count rollback-count) t)
|
|
;; rollback the package
|
|
(spacemacs/replace-last-line-of-buffer
|
|
(format "--> rollbacking package %s... [%s/%s]"
|
|
pkg rollbacked-count rollback-count) t)
|
|
(configuration-layer//package-delete pkg)
|
|
(copy-directory src-dir dest-dir 'keeptime 'create 'copy-content))
|
|
(spacemacs//redisplay)))
|
|
(spacemacs/append-to-buffer
|
|
(format "\n--> %s packages rollbacked.\n" rollbacked-count))
|
|
(spacemacs/append-to-buffer
|
|
"\nEmacs has to be restarted for the changes to take effect.\n")))))
|
|
|
|
(defun configuration-layer//initialize-packages ()
|
|
"Initialize all the declared packages."
|
|
(mapc (lambda (x)
|
|
(spacemacs/message (format "Package: Initializing %S..." x))
|
|
(configuration-layer//eval-init-functions
|
|
x (ht-get configuration-layer-packages-init-funcs x)))
|
|
configuration-layer-all-packages-sorted))
|
|
|
|
(defun configuration-layer//initialize-pre-extensions ()
|
|
"Initialize all the declared pre-extensions."
|
|
(mapc (lambda (x)
|
|
(spacemacs/message (format "Pre-extension: Initializing %S..." x))
|
|
(configuration-layer//eval-init-functions
|
|
x (ht-get configuration-layer-pre-extensions-init-funcs x) t))
|
|
configuration-layer-all-pre-extensions-sorted))
|
|
|
|
(defun configuration-layer//initialize-post-extensions ()
|
|
"Initialize all the declared post-extensions."
|
|
(mapc (lambda (x)
|
|
(spacemacs/message (format "Post-extension: Initializing %S..." x))
|
|
(configuration-layer//eval-init-functions
|
|
x (ht-get configuration-layer-post-extensions-init-funcs x) t))
|
|
configuration-layer-all-post-extensions-sorted))
|
|
|
|
(defun configuration-layer//eval-init-functions (pkg funcs &optional extension-p)
|
|
"Initialize the package PKG by evaluating the functions of FUNCS."
|
|
(when (or extension-p (package-installed-p pkg))
|
|
(configuration-layer//activate-package pkg)
|
|
(dolist (f funcs)
|
|
(spacemacs/message (format "-> %S..." f))
|
|
(condition-case err
|
|
(funcall f)
|
|
('error
|
|
(configuration-layer//set-error)
|
|
(spacemacs/append-to-buffer
|
|
(format (concat "An error occurred while initializing %s "
|
|
"(error: %s)\n") pkg err)))))
|
|
(spacemacs/loading-animation)))
|
|
|
|
(defun configuration-layer//activate-package (pkg)
|
|
"Activate PKG."
|
|
(if (version< emacs-version "24.3.50")
|
|
;; fake version list to always activate the package
|
|
(package-activate pkg '(0 0 0 0))
|
|
(package-activate pkg)))
|
|
|
|
(defun configuration-layer//initialized-packages-count ()
|
|
"Return the number of initialized packages and extensions."
|
|
(+ (ht-size configuration-layer-all-packages)
|
|
(ht-size configuration-layer-all-pre-extensions)
|
|
(ht-size configuration-layer-all-post-extensions)))
|
|
|
|
(defun configuration-layer/get-layer-property (symlayer prop)
|
|
"Return the value of the PROPerty for the given SYMLAYER symbol."
|
|
(let* ((layer (assq symlayer configuration-layer-layers)))
|
|
(plist-get (cdr layer) prop)))
|
|
|
|
(defun configuration-layer//get-packages-dependencies ()
|
|
"Returns a hash map where key is a dependency package symbol and value is
|
|
a list of all packages which depend on it."
|
|
(let ((result (make-hash-table :size 256)))
|
|
(dolist (pkg package-alist)
|
|
(let* ((pkg-sym (car pkg))
|
|
(deps (configuration-layer//get-package-dependencies pkg-sym)))
|
|
(dolist (dep deps)
|
|
(let* ((dep-sym (car dep))
|
|
(value (ht-get result dep-sym)))
|
|
(puthash dep-sym
|
|
(if value (add-to-list 'value pkg-sym) (list pkg-sym))
|
|
result)))))
|
|
result))
|
|
|
|
(defun configuration-layer//get-implicit-packages ()
|
|
"Returns a list of all packages in `packages-alist' which are not found
|
|
in `configuration-layer-all-packages'"
|
|
(let ((imp-pkgs))
|
|
(dolist (pkg package-alist)
|
|
(let ((pkg-sym (car pkg)))
|
|
(if (not (ht-contains? configuration-layer-all-packages pkg-sym))
|
|
(add-to-list 'imp-pkgs pkg-sym))))
|
|
imp-pkgs))
|
|
|
|
(defun configuration-layer//get-orphan-packages (implicit-pkgs dependencies)
|
|
"Return a list of all orphan packages which are basically meant to be
|
|
deleted safely."
|
|
(let ((result '()))
|
|
(dolist (imp-pkg implicit-pkgs)
|
|
(if (configuration-layer//is-package-orphan imp-pkg dependencies)
|
|
(add-to-list 'result imp-pkg)))
|
|
result))
|
|
|
|
(defun configuration-layer//is-package-orphan (pkg dependencies)
|
|
"Returns not nil if PKG is an orphan package."
|
|
(if (ht-contains? configuration-layer-all-packages pkg)
|
|
nil
|
|
(if (ht-contains? dependencies pkg)
|
|
(let ((parents (ht-get dependencies pkg)))
|
|
(reduce (lambda (x y) (and x y))
|
|
(mapcar (lambda (p) (configuration-layer//is-package-orphan
|
|
p dependencies))
|
|
parents)
|
|
:initial-value t))
|
|
(not (ht-contains? configuration-layer-all-packages pkg)))))
|
|
|
|
(defun configuration-layer//get-package-directory (pkg)
|
|
"Return the directory path for PKG."
|
|
(let ((pkg-desc (assq pkg package-alist)))
|
|
(cond
|
|
((version< emacs-version "24.3.50")
|
|
(let* ((version (aref (cdr pkg-desc) 0))
|
|
(elpa-dir (concat user-emacs-directory "elpa/"))
|
|
(pkg-dir-name (format "%s-%s.%s"
|
|
(symbol-name pkg)
|
|
(car version)
|
|
(cadr version))))
|
|
(expand-file-name (concat elpa-dir pkg-dir-name))))
|
|
(t (package-desc-dir (cadr pkg-desc))))))
|
|
|
|
(defun configuration-layer//get-package-dependencies (pkg)
|
|
"Return the dependencies alist for PKG."
|
|
(let ((pkg-desc (assq pkg package-alist)))
|
|
(cond
|
|
((version< emacs-version "24.3.50") (aref (cdr pkg-desc) 1))
|
|
(t (package-desc-reqs (cadr pkg-desc))))))
|
|
|
|
(defun configuration-layer//get-package-dependencies-from-archive (pkg)
|
|
"Return the dependencies alist for a PKG from the archive data."
|
|
(let* ((pkg-arch (assq pkg package-archive-contents))
|
|
(reqs (when pkg-arch (if (version< emacs-version "24.3.50")
|
|
(aref (cdr pkg-arch) 1)
|
|
(package-desc-reqs (cadr pkg-arch))))))
|
|
;; recursively get the requirements of reqs
|
|
(dolist (req reqs)
|
|
(let* ((pkg2 (car req))
|
|
(reqs2 (configuration-layer//get-package-dependencies-from-archive pkg2)))
|
|
(when reqs2 (setq reqs (append reqs2 reqs)))))
|
|
reqs))
|
|
|
|
(defun configuration-layer//get-package-version-string (pkg)
|
|
"Return the version string for PKG."
|
|
(let ((pkg-desc (assq pkg package-alist)))
|
|
(when pkg-desc
|
|
(cond
|
|
((version< emacs-version "24.3.50") (package-version-join
|
|
(aref (cdr pkg-desc) 0)))
|
|
(t (package-version-join (package-desc-version (cadr pkg-desc))))))))
|
|
|
|
(defun configuration-layer//get-package-version (pkg)
|
|
"Return the version list for PKG."
|
|
(let ((version-string (configuration-layer//get-package-version-string pkg)))
|
|
(unless (string-empty-p version-string)
|
|
(version-to-list version-string))))
|
|
|
|
(defun configuration-layer//get-latest-package-version-string (pkg)
|
|
"Return the version string for PKG."
|
|
(let ((pkg-arch (assq pkg package-archive-contents)))
|
|
(when pkg-arch
|
|
(cond
|
|
((version< emacs-version "24.3.50") (package-version-join
|
|
(aref (cdr pkg-arch) 0)))
|
|
(t (package-version-join (package-desc-version (cadr pkg-arch))))))))
|
|
|
|
(defun configuration-layer//get-latest-package-version (pkg)
|
|
"Return the versio list for PKG."
|
|
(let ((version-string
|
|
(configuration-layer//get-latest-package-version-string pkg)))
|
|
(unless (string-empty-p version-string)
|
|
(version-to-list version-string))))
|
|
|
|
(defun configuration-layer//package-delete (pkg)
|
|
"Delete the passed PKG."
|
|
(cond
|
|
((version< emacs-version "24.3.50")
|
|
(let ((v (configuration-layer//get-package-version-string pkg)))
|
|
(when v (package-delete (symbol-name pkg) v))))
|
|
(t (let ((p (cadr (assq pkg package-alist))))
|
|
(when p (package-delete p))))))
|
|
|
|
(defun configuration-layer/delete-orphan-packages ()
|
|
"Delete all the orphan packages."
|
|
(interactive)
|
|
(let* ((dependencies (configuration-layer//get-packages-dependencies))
|
|
(implicit-packages (configuration-layer//get-implicit-packages))
|
|
(orphans (configuration-layer//get-orphan-packages implicit-packages
|
|
dependencies))
|
|
(orphans-count (length orphans)))
|
|
;; (message "dependencies: %s" dependencies)
|
|
;; (message "implicit: %s" implicit-packages)
|
|
;; (message "orphans: %s" orphans)
|
|
(if orphans
|
|
(progn
|
|
(spacemacs/append-to-buffer
|
|
(format "Found %s orphan package(s) to delete...\n"
|
|
orphans-count))
|
|
(setq deleted-count 0)
|
|
(dolist (orphan orphans)
|
|
(setq deleted-count (1+ deleted-count))
|
|
(spacemacs/replace-last-line-of-buffer
|
|
(format "--> deleting %s... [%s/%s]"
|
|
orphan
|
|
deleted-count
|
|
orphans-count) t)
|
|
(configuration-layer//package-delete orphan)
|
|
(spacemacs//redisplay))
|
|
(spacemacs/append-to-buffer "\n"))
|
|
(spacemacs/message "No orphan package to delete."))))
|
|
|
|
(defun configuration-layer//set-error ()
|
|
"Set the error flag and change the mode-line color to red."
|
|
(if configuration-layer-error-count
|
|
(setq configuration-layer-error-count
|
|
(1+ configuration-layer-error-count))
|
|
(face-remap-add-relative 'mode-line '((:background "red") mode-line))
|
|
(setq configuration-layer-error-count 1)))
|
|
|
|
(provide 'core-configuration-layer)
|