TakeV
/
spacemacs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Built-in files auto-update: Sun Jan 10 20:14:15 UTC 2021

This commit is contained in:
emacspace 2021-01-10 20:14:15 +00:00 committed by Eugene Yaremenko
parent a29babe830
commit 01f8ccbefb
11 changed files with 1343 additions and 1249 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1329
core/libs/dash.el
View File

File diff suppressed because it is too large Load Diff

105
core/libs/ht.el
View File

@ -1,9 +1,9 @@
;;; ht.el --- The missing hash table library for Emacs ;;; ht.el --- The missing hash table library for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 2013 Wilfred Hughes ;; Copyright (C) 2013 Wilfred Hughes
;; Author: Wilfred Hughes <me@wilfred.me.uk> ;; Author: Wilfred Hughes <me@wilfred.me.uk>
;; Version: 2.2 ;; Version: 2.3
;; Keywords: hash table, hash map, hash ;; Keywords: hash table, hash map, hash
;; Package-Requires: ((dash "2.12.0")) ;; Package-Requires: ((dash "2.12.0"))
@ -29,6 +29,9 @@
;;; Code: ;;; Code:
(require 'dash) (require 'dash)
(require 'gv)
(eval-when-compile
(require 'inline))
(defmacro ht (&rest pairs) (defmacro ht (&rest pairs)
"Create a hash table with the key-value pairs given. "Create a hash table with the key-value pairs given.
@ -44,13 +47,22 @@ Keys are compared with `equal'.
,@assignments ,@assignments
,table-symbol))) ,table-symbol)))
(defsubst ht-create (&optional test) (define-inline ht-set! (table key value)
"Associate KEY in TABLE with VALUE."
(inline-quote
(prog1 nil
(puthash ,key ,value ,table))))
(defalias 'ht-set 'ht-set!)
(define-inline ht-create (&optional test)
"Create an empty hash table. "Create an empty hash table.
TEST indicates the function used to compare the hash TEST indicates the function used to compare the hash
keys. Default is `equal'. It can be `eq', `eql', `equal' or a keys. Default is `equal'. It can be `eq', `eql', `equal' or a
user-supplied test created via `define-hash-table-test'." user-supplied test created via `define-hash-table-test'."
(make-hash-table :test (or test 'equal))) (declare (side-effect-free t))
(inline-quote (make-hash-table :test (or ,test 'equal))))
(defun ht<-alist (alist &optional test) (defun ht<-alist (alist &optional test)
"Create a hash table with initial values according to ALIST. "Create a hash table with initial values according to ALIST.
@ -58,6 +70,7 @@ user-supplied test created via `define-hash-table-test'."
TEST indicates the function used to compare the hash TEST indicates the function used to compare the hash
keys. Default is `equal'. It can be `eq', `eql', `equal' or a keys. Default is `equal'. It can be `eq', `eql', `equal' or a
user-supplied test created via `define-hash-table-test'." user-supplied test created via `define-hash-table-test'."
(declare (side-effect-free t))
(let ((h (ht-create test))) (let ((h (ht-create test)))
;; the first key-value pair in an alist gets precedence, so we ;; the first key-value pair in an alist gets precedence, so we
;; start from the end of the list: ;; start from the end of the list:
@ -74,33 +87,40 @@ user-supplied test created via `define-hash-table-test'."
TEST indicates the function used to compare the hash TEST indicates the function used to compare the hash
keys. Default is `equal'. It can be `eq', `eql', `equal' or a keys. Default is `equal'. It can be `eq', `eql', `equal' or a
user-supplied test created via `define-hash-table-test'." user-supplied test created via `define-hash-table-test'."
(declare (side-effect-free t))
(let ((h (ht-create test))) (let ((h (ht-create test)))
(dolist (pair (-partition 2 plist) h) (dolist (pair (nreverse (-partition 2 plist)) h)
(let ((key (car pair)) (let ((key (car pair))
(value (cadr pair))) (value (cadr pair)))
(ht-set! h key value))))) (ht-set! h key value)))))
(defalias 'ht-from-plist 'ht<-plist) (defalias 'ht-from-plist 'ht<-plist)
(defsubst ht-get (table key &optional default) (define-inline ht-get (table key &optional default)
"Look up KEY in TABLE, and return the matching value. "Look up KEY in TABLE, and return the matching value.
If KEY isn't present, return DEFAULT (nil if not specified)." If KEY isn't present, return DEFAULT (nil if not specified)."
(gethash key table default)) (declare (side-effect-free t))
(inline-quote
(gethash ,key ,table ,default)))
(defun ht-get* (table &rest keys) ;; Don't use `ht-set!' here, gv setter was assumed to return the value
;; to be set.
(gv-define-setter ht-get (value table key) `(puthash ,key ,value ,table))
(define-inline ht-get* (table &rest keys)
"Look up KEYS in nested hash tables, starting with TABLE. "Look up KEYS in nested hash tables, starting with TABLE.
The lookup for each key should return another hash table, except The lookup for each key should return another hash table, except
for the final key, which may return any value." for the final key, which may return any value."
(if (cdr keys) (declare (side-effect-free t))
(apply #'ht-get* (ht-get table (car keys)) (cdr keys)) (inline-letevals (table keys)
(ht-get table (car keys)))) (inline-quote
(prog1 ,table
(while ,keys
(setf ,table (ht-get table (pop ,keys))))))))
(defsubst ht-set! (table key value) (put 'ht-get* 'compiler-macro
"Associate KEY in TABLE with VALUE." (lambda (_ table &rest keys)
(puthash key value table) (--reduce-from `(ht-get ,acc ,it) table keys)))
nil)
(defalias 'ht-set 'ht-set!)
(defun ht-update! (table from-table) (defun ht-update! (table from-table)
"Update TABLE according to every key-value pair in FROM-TABLE." "Update TABLE according to every key-value pair in FROM-TABLE."
@ -119,16 +139,17 @@ table is used."
(mapc (lambda (table) (ht-update! merged table)) tables) (mapc (lambda (table) (ht-update! merged table)) tables)
merged)) merged))
(defsubst ht-remove! (table key) (define-inline ht-remove! (table key)
"Remove KEY from TABLE." "Remove KEY from TABLE."
(remhash key table)) (inline-quote (remhash ,key ,table)))
(defalias 'ht-remove 'ht-remove!) (defalias 'ht-remove 'ht-remove!)
(defsubst ht-clear! (table) (define-inline ht-clear! (table)
"Remove all keys from TABLE." "Remove all keys from TABLE."
(clrhash table) (inline-quote
nil) (prog1 nil
(clrhash ,table))))
(defalias 'ht-clear 'ht-clear!) (defalias 'ht-clear 'ht-clear!)
@ -145,19 +166,23 @@ FUNCTION is called with two arguments, KEY and VALUE."
(defmacro ht-amap (form table) (defmacro ht-amap (form table)
"Anaphoric version of `ht-map'. "Anaphoric version of `ht-map'.
For every key-value pair in TABLE, evaluate FORM with the For every key-value pair in TABLE, evaluate FORM with the
variables KEY and VALUE bound." variables KEY and VALUE bound. If you don't use both of
these variables, then use `ht-map' to avoid warnings."
`(ht-map (lambda (key value) ,form) ,table)) `(ht-map (lambda (key value) ,form) ,table))
(defun ht-keys (table) (defun ht-keys (table)
"Return a list of all the keys in TABLE." "Return a list of all the keys in TABLE."
(ht-amap key table)) (declare (side-effect-free t))
(ht-map (lambda (key _value) key) table))
(defun ht-values (table) (defun ht-values (table)
"Return a list of all the values in TABLE." "Return a list of all the values in TABLE."
(ht-amap value table)) (declare (side-effect-free t))
(ht-map (lambda (_key value) value) table))
(defun ht-items (table) (defun ht-items (table)
"Return a list of two-element lists '(key value) from TABLE." "Return a list of two-element lists '(key value) from TABLE."
(declare (side-effect-free t))
(ht-amap (list key value) table)) (ht-amap (list key value) table))
(defalias 'ht-each 'maphash (defalias 'ht-each 'maphash
@ -172,6 +197,7 @@ variables key and value bound."
(defun ht-select-keys (table keys) (defun ht-select-keys (table keys)
"Return a copy of TABLE with only the specified KEYS." "Return a copy of TABLE with only the specified KEYS."
(declare (side-effect-free t))
(let (result) (let (result)
(setq result (make-hash-table :test (hash-table-test table))) (setq result (make-hash-table :test (hash-table-test table)))
(dolist (key keys result) (dolist (key keys result)
@ -187,13 +213,15 @@ inverse of `ht<-plist'. The following is not guaranteed:
\(let ((data '(a b c d))) \(let ((data '(a b c d)))
(equalp data (equalp data
(ht->plist (ht<-plist data))))" (ht->plist (ht<-plist data))))"
(declare (side-effect-free t))
(apply 'append (ht-items table))) (apply 'append (ht-items table)))
(defalias 'ht-to-plist 'ht->plist) (defalias 'ht-to-plist 'ht->plist)
(defsubst ht-copy (table) (define-inline ht-copy (table)
"Return a shallow copy of TABLE (keys and values are shared)." "Return a shallow copy of TABLE (keys and values are shared)."
(copy-hash-table table)) (declare (side-effect-free t))
(inline-quote (copy-hash-table ,table)))
(defun ht->alist (table) (defun ht->alist (table)
"Return a list of two-element lists '(key . value) from TABLE. "Return a list of two-element lists '(key . value) from TABLE.
@ -204,6 +232,7 @@ inverse of `ht<-alist'. The following is not guaranteed:
\(let ((data '((a . b) (c . d)))) \(let ((data '((a . b) (c . d))))
(equalp data (equalp data
(ht->alist (ht<-alist data))))" (ht->alist (ht<-alist data))))"
(declare (side-effect-free t))
(ht-amap (cons key value) table)) (ht-amap (cons key value) table))
(defalias 'ht-to-alist 'ht->alist) (defalias 'ht-to-alist 'ht->alist)
@ -212,19 +241,28 @@ inverse of `ht<-alist'. The following is not guaranteed:
(defalias 'ht-p 'hash-table-p) (defalias 'ht-p 'hash-table-p)
(defun ht-contains? (table key) (define-inline ht-contains? (table key)
"Return 't if TABLE contains KEY." "Return 't if TABLE contains KEY."
(not (eq (ht-get table key 'ht--not-found) 'ht--not-found))) (declare (side-effect-free t))
(inline-quote
(let ((not-found-symbol (make-symbol "ht--not-found")))
(not (eq (ht-get ,table ,key not-found-symbol) not-found-symbol)))))
(defalias 'ht-contains-p 'ht-contains?) (defalias 'ht-contains-p 'ht-contains?)
(defsubst ht-size (table) (define-inline ht-size (table)
"Return the actual number of entries in TABLE." "Return the actual number of entries in TABLE."
(hash-table-count table)) (declare (side-effect-free t))
(inline-quote
(hash-table-count ,table)))
(defsubst ht-empty? (table) (define-inline ht-empty? (table)
"Return true if the actual number of entries in TABLE is zero." "Return true if the actual number of entries in TABLE is zero."
(zerop (ht-size table))) (declare (side-effect-free t))
(inline-quote
(zerop (ht-size ,table))))
(defalias 'ht-empty-p 'ht-empty?)
(defun ht-select (function table) (defun ht-select (function table)
"Return a hash table containing all entries in TABLE for which "Return a hash table containing all entries in TABLE for which
@ -280,6 +318,7 @@ FUNCTION is called with two arguments, KEY and VALUE."
(defun ht-equal? (table1 table2) (defun ht-equal? (table1 table2)
"Return t if TABLE1 and TABLE2 have the same keys and values. "Return t if TABLE1 and TABLE2 have the same keys and values.
Does not compare equality predicates." Does not compare equality predicates."
(declare (side-effect-free t))
(let ((keys1 (ht-keys table1)) (let ((keys1 (ht-keys table1))
(keys2 (ht-keys table2)) (keys2 (ht-keys table2))
(sentinel (make-symbol "ht-sentinel"))) (sentinel (make-symbol "ht-sentinel")))

2
core/libs/ido-vertical-mode.el
View File

@ -5,7 +5,6 @@
;; Author: Steven Degutis ;; Author: Steven Degutis
;; Maintainer: Christopher Reichert <creichert07@gmail.com> ;; Maintainer: Christopher Reichert <creichert07@gmail.com>
;; Version: 1.0.0 ;; Version: 1.0.0
;; Package-Version: 20180618.2101
;; Keywords: convenience ;; Keywords: convenience
;; URL: https://github.com/creichert/ido-vertical-mode.el ;; URL: https://github.com/creichert/ido-vertical-mode.el
@ -29,6 +28,7 @@
;;; Code: ;;; Code:
(require 'ido) (require 'ido)
(require 'cl-lib)
;;; The following three variables and their comments are lifted ;;; The following three variables and their comments are lifted
;;; directly from `ido.el'; they are defined here to avoid compile-log ;;; directly from `ido.el'; they are defined here to avoid compile-log

24
core/libs/package-build-badges.el
View File

@ -1,4 +1,4 @@
;;; package-build-badges.el --- Create batches for packages ;;; package-build-badges.el --- Create batches for packages -*- lexical-binding: t -*-
;; Copyright (C) 2011-2013 Donald Ephraim Curtis <dcurtis@milkbox.net> ;; Copyright (C) 2011-2013 Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Copyright (C) 2012-2014 Steve Purcell <steve@sanityinc.com> ;; Copyright (C) 2012-2014 Steve Purcell <steve@sanityinc.com>
@ -36,16 +36,20 @@
(require 'package-build) (require 'package-build)
(defun package-build--write-melpa-badge-image (name version target-dir) (defun package-build--write-melpa-badge-image (name version target-dir)
(shell-command (unless (zerop (call-process
(mapconcat #'shell-quote-argument "curl" nil nil nil "-f" "-o"
(list "curl" "-f" "-o" (expand-file-name (concat name "-badge.svg") target-dir)
(expand-file-name (concat name "-badge.svg") target-dir) (format "https://img.shields.io/badge/%s-%s-%s.svg"
(format "https://img.shields.io/badge/%s-%s-%s.svg" (if package-build-stable "melpa stable" "melpa")
(if package-build-stable "melpa stable" "melpa") (url-hexify-string version)
(url-hexify-string version) (if package-build-stable "3e999f" "922793"))))
(if package-build-stable "3e999f" "922793"))) (message "Failed to fetch badge")))
" ")))
(provide 'package-build-badges) (provide 'package-build-badges)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End: ;; End:
;;; package-badges.el ends here ;;; package-badges.el ends here

679
core/libs/package-build.el
View File

@ -1,13 +1,15 @@
;;; package-build.el --- Tools for assembling a package archive ;;; package-build.el --- Tools for assembling a package archive -*- lexical-binding: t -*-
;; Copyright (C) 2011-2020 Donald Ephraim Curtis <dcurtis@milkbox.net> ;; Copyright (C) 2011-2021 Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Copyright (C) 2012-2020 Steve Purcell <steve@sanityinc.com> ;; Copyright (C) 2012-2021 Steve Purcell <steve@sanityinc.com>
;; Copyright (C) 2016-2020 Jonas Bernoulli <jonas@bernoul.li> ;; Copyright (C) 2016-2021 Jonas Bernoulli <jonas@bernoul.li>
;; Copyright (C) 2009 Phil Hagelberg <technomancy@gmail.com> ;; Copyright (C) 2009 Phil Hagelberg <technomancy@gmail.com>
;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net> ;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Keywords: tools ;; Keywords: tools
;; Package-Requires: ((cl-lib "0.5") (emacs "24.1")) ;; Homepage: https://github.com/melpa/package-build
;; Package-Requires: ((cl-lib "0.5") (emacs "25.1"))
;; Package-Version: 0-git
;; This file is not (yet) part of GNU Emacs. ;; This file is not (yet) part of GNU Emacs.
;; However, it is distributed under the same license. ;; However, it is distributed under the same license.
@ -39,6 +41,8 @@
;;; Code: ;;; Code:
(require 'cl-lib) (require 'cl-lib)
(require 'pcase)
(require 'subr-x)
(require 'package) (require 'package)
(require 'lisp-mnt) (require 'lisp-mnt)
@ -198,7 +202,8 @@ is used instead."
(file-name-as-directory (or directory default-directory))) (file-name-as-directory (or directory default-directory)))
(argv (nconc (unless (eq system-type 'windows-nt) (argv (nconc (unless (eq system-type 'windows-nt)
(list "env" "LC_ALL=C")) (list "env" "LC_ALL=C"))
(if (and package-build-timeout-secs package-build-timeout-executable) (if (and package-build-timeout-secs
package-build-timeout-executable)
(nconc (list package-build-timeout-executable (nconc (list package-build-timeout-executable
"-k" "60" (number-to-string "-k" "60" (number-to-string
package-build-timeout-secs) package-build-timeout-secs)
@ -229,20 +234,14 @@ is used instead."
;;; Checkout ;;; Checkout
;;;; Common ;;;; Common
(defmethod package-build--checkout :before ((rcp package-recipe)) (cl-defmethod package-build--checkout :before ((rcp package-recipe))
(package-build--message "Package: %s" (oref rcp name)) (package-build--message "Package: %s" (oref rcp name))
(package-build--message "Fetcher: %s" (package-build--message "Fetcher: %s" (package-recipe--fetcher rcp))
(substring (symbol-name
(with-no-warnings
;; Use eieio-object-class once we
;; no longer support Emacs 24.3.
(object-class-fast rcp)))
8 -7))
(package-build--message "Source: %s\n" (package-recipe--upstream-url rcp))) (package-build--message "Source: %s\n" (package-recipe--upstream-url rcp)))
;;;; Git ;;;; Git
(defmethod package-build--checkout ((rcp package-git-recipe)) (cl-defmethod package-build--checkout ((rcp package-git-recipe))
(let ((dir (package-recipe--working-tree rcp)) (let ((dir (package-recipe--working-tree rcp))
(url (package-recipe--upstream-url rcp))) (url (package-recipe--upstream-url rcp)))
(cond (cond
@ -271,7 +270,7 @@ is used instead."
(package-build--expand-source-file-list rcp))) (package-build--expand-source-file-list rcp)))
(oref rcp tag-regexp))))) (oref rcp tag-regexp)))))
(defmethod package-build--checkout-1 ((rcp package-git-recipe) &optional rev) (cl-defmethod package-build--checkout-1 ((rcp package-git-recipe) &optional rev)
(let ((dir (package-recipe--working-tree rcp))) (let ((dir (package-recipe--working-tree rcp)))
(unless rev (unless rev
(setq rev (or (oref rcp commit) (setq rev (or (oref rcp commit)
@ -287,13 +286,20 @@ is used instead."
(package-build--run-process dir nil "git" "submodule" "update" (package-build--run-process dir nil "git" "submodule" "update"
"--init" "--recursive"))) "--init" "--recursive")))
(defmethod package-build--used-url ((rcp package-git-recipe)) (cl-defmethod package-build--used-url ((rcp package-git-recipe))
(let ((default-directory (package-recipe--working-tree rcp))) (let ((default-directory (package-recipe--working-tree rcp)))
(car (process-lines "git" "config" "remote.origin.url")))) (car (process-lines "git" "config" "remote.origin.url"))))
(cl-defmethod package-build--get-commit ((rcp package-git-recipe))
(ignore-errors
(package-build--run-process-match
"\\(.*\\)"
(package-recipe--working-tree rcp)
"git" "rev-parse" "HEAD")))
;;;; Hg ;;;; Hg
(defmethod package-build--checkout ((rcp package-hg-recipe)) (cl-defmethod package-build--checkout ((rcp package-hg-recipe))
(let ((dir (package-recipe--working-tree rcp)) (let ((dir (package-recipe--working-tree rcp))
(url (package-recipe--upstream-url rcp))) (url (package-recipe--upstream-url rcp)))
(cond (cond
@ -325,84 +331,122 @@ is used instead."
(package-build--expand-source-file-list rcp))) (package-build--expand-source-file-list rcp)))
(oref rcp tag-regexp))))) (oref rcp tag-regexp)))))
(defmethod package-build--used-url ((rcp package-hg-recipe)) (cl-defmethod package-build--used-url ((rcp package-hg-recipe))
(package-build--run-process-match "default = \\(.*\\)" (package-build--run-process-match "default = \\(.*\\)"
(package-recipe--working-tree rcp) (package-recipe--working-tree rcp)
"hg" "paths")) "hg" "paths"))
;;; Various Files (cl-defmethod package-build--get-commit ((rcp package-hg-recipe))
(ignore-errors
(package-build--run-process-match
"changeset:[[:space:]]+[[:digit:]]+:\\([[:xdigit:]]+\\)"
(package-recipe--working-tree rcp)
"hg" "log" "--debug" "--limit=1")))
(defun package-build--write-pkg-file (pkg-file pkg-info) ;;; Generate Files
"Write PKG-FILE containing PKG-INFO."
(with-temp-file pkg-file
(pp
`(define-package
,(aref pkg-info 0)
,(aref pkg-info 3)
,(aref pkg-info 2)
',(mapcar
(lambda (elt)
(list (car elt)
(package-version-join (cadr elt))))
(aref pkg-info 1))
;; Append our extra information
,@(cl-mapcan (lambda (entry)
(let ((value (cdr entry)))
(when (or (symbolp value) (listp value))
;; We must quote lists and symbols,
;; because Emacs 24.3 and earlier evaluate
;; the package information, which would
;; break for unquoted symbols or lists
(setq value (list 'quote value)))
(list (car entry) value)))
(when (> (length pkg-info) 4)
(aref pkg-info 4))))
(current-buffer))
(princ ";; Local Variables:\n;; no-byte-compile: t\n;; End:\n"
(current-buffer))))
(defun package-build--create-tar (file dir &optional files) (defun package-build--write-pkg-file (desc dir)
"Create a tar FILE containing the contents of DIR, or just FILES if non-nil." (let ((name (package-desc-name desc)))
(when (eq system-type 'windows-nt) (with-temp-file (expand-file-name (format "%s-pkg.el" name) dir)
(setq file (replace-regexp-in-string "^\\([a-z]\\):" "/\\1" file))) (pp `(define-package ,(symbol-name name)
(apply 'process-file ,(package-version-join (package-desc-version desc))
package-build-tar-executable nil ,(package-desc-summary desc)
(get-buffer-create "*package-build-checkout*") ',(mapcar (pcase-lambda (`(,pkg ,ver))
nil "-cvf" (list pkg (package-version-join ver)))
file (package-desc-reqs desc))
"--exclude=.git" ,@(cl-mapcan (pcase-lambda (`(,key . ,val))
"--exclude=.hg" (when (or (symbolp val) (listp val))
(or (mapcar (lambda (fn) (concat dir "/" fn)) files) (list dir)))) ;; We must quote lists and symbols,
;; because Emacs 24.3 and earlier evaluate
;; the package information, which would
;; break for unquoted symbols or lists.
;; While this library does not support
;; such old Emacsen, the packages that
;; we produce should remain compatible.
(setq val (list 'quote val)))
(list key val))
(package-desc-extras desc)))
(current-buffer))
(princ ";; Local Variables:\n;; no-byte-compile: t\n;; End:\n"
(current-buffer)))))
(defun package-build--find-package-commentary (file-path) (defun package-build--create-tar (name version directory)
"Get commentary section from FILE-PATH." "Create a tar file containing the contents of VERSION of package NAME."
(when (file-exists-p file-path) (let ((tar (expand-file-name (concat name "-" version ".tar")
package-build-archive-dir))
(dir (concat name "-" version)))
(when (eq system-type 'windows-nt)
(setq tar (replace-regexp-in-string "^\\([a-z]\\):" "/\\1" tar)))
(let ((default-directory directory))
(process-file package-build-tar-executable nil
(get-buffer-create "*package-build-checkout*") nil
"-cvf" tar
"--exclude=.git"
"--exclude=.hg"
dir))
(when (and package-build-verbose noninteractive)
(message "Created %s containing:" (file-name-nondirectory tar))
(dolist (line (sort (process-lines package-build-tar-executable
"--list" "--file" tar)
#'string<))
(message " %s" line)))))
(defun package-build--write-pkg-readme (name files directory)
(when-let ((commentary
(let* ((file (concat name ".el"))
(file (or (car (rassoc file files)) file))
(file (and file (expand-file-name file directory))))
(and (file-exists-p file)
(lm-commentary file)))))
(with-temp-buffer (with-temp-buffer
(insert-file-contents file-path) (if (>= emacs-major-version 27)
(lm-commentary)))) (insert commentary)
;; Taken from 27.1's `lm-commentary'.
(defun package-build--write-pkg-readme (target-dir commentary file-name) (insert
"In TARGET-DIR, write COMMENTARY to a -readme.txt file prefixed with FILE-NAME." (replace-regexp-in-string ; Get rid of...
(when commentary "[[:blank:]]*$" "" ; trailing white-space
(with-temp-buffer (replace-regexp-in-string
(insert commentary) (format "%s\\|%s\\|%s"
;; Adapted from `describe-package-1'. ;; commentary header
(goto-char (point-min)) (concat "^;;;[[:blank:]]*\\("
(save-excursion lm-commentary-header
(when (re-search-forward "^;;; Commentary:\n" nil t) "\\):[[:blank:]\n]*")
(replace-match "")) "^;;[[:blank:]]*" ; double semicolon prefix
(while (re-search-forward "^\\(;+ ?\\)" nil t) "[[:blank:]\n]*\\'") ; trailing new-lines
(replace-match "")) "" commentary))))
(goto-char (point-min)) (unless (= (char-before) ?\n)
(when (re-search-forward "\\`\\( *\n\\)+" nil t) (insert ?\n))
(replace-match "")))
(delete-trailing-whitespace)
(let ((coding-system-for-write buffer-file-coding-system)) (let ((coding-system-for-write buffer-file-coding-system))
(write-region nil nil (write-region nil nil
(expand-file-name (concat file-name "-readme.txt") (expand-file-name (concat name "-readme.txt")
target-dir)))))) package-build-archive-dir))))))
;;; Entries (defun package-build--generate-info-files (files source-dir target-dir)
"Create an info file for each texinfo file listed in FILES.
Also create the info dir file. Remove each original texinfo
file. The source and destination file paths are expanded in
SOURCE-DIR and TARGET-DIR respectively."
(pcase-dolist (`(,src . ,tmp) files)
(let ((extension (file-name-extension tmp)))
(when (member extension '("info" "texi" "texinfo"))
(setq src (expand-file-name src source-dir))
(setq tmp (expand-file-name tmp target-dir))
(let ((info tmp))
(when (member extension '("texi" "texinfo"))
(unwind-protect
(progn
(setq info (concat (file-name-sans-extension tmp) ".info"))
(unless (file-exists-p info)
(with-demoted-errors "Error: %S"
(package-build--run-process
source-dir nil "makeinfo" src "-o" info))
(package-build--message "Created %s" info)))
(delete-file tmp)))
(with-demoted-errors "Error: %S"
(package-build--run-process
target-dir nil "install-info" "--dir=dir" info)))))))
;;; Patch Libraries
(defun package-build--update-or-insert-header (name value) (defun package-build--update-or-insert-header (name value)
"Ensure current buffer has NAME header with the given VALUE. "Ensure current buffer has NAME header with the given VALUE.
@ -425,12 +469,12 @@ still be renamed."
(insert (format ";; %s: %s" name value)) (insert (format ";; %s: %s" name value))
(newline)) (newline))
(defun package-build--ensure-ends-here-line (file-path) (defun package-build--ensure-ends-here-line (file)
"Add a 'FILE-PATH ends here' trailing line if missing." "Add a 'FILE ends here' trailing line if missing."
(save-excursion (save-excursion
(goto-char (point-min)) (goto-char (point-min))
(let ((trailer (concat ";;; " (let ((trailer (concat ";;; "
(file-name-nondirectory file-path) (file-name-nondirectory file)
" ends here"))) " ends here")))
(unless (search-forward trailer nil t) (unless (search-forward trailer nil t)
(goto-char (point-max)) (goto-char (point-max))
@ -438,143 +482,86 @@ still be renamed."
(insert trailer) (insert trailer)
(newline))))) (newline)))))
(defun package-build--get-package-info (file-path) ;;; Package Structs
"Get a vector of package info from the docstrings in FILE-PATH."
(when (file-exists-p file-path)
(ignore-errors
(with-temp-buffer
(insert-file-contents file-path)
;; next few lines are a hack for some packages that aren't
;; commented properly.
(package-build--update-or-insert-header "Package-Version" "0")
(package-build--ensure-ends-here-line file-path)
(cl-flet ((package-strip-rcs-id (str) "0"))
(package-build--package-buffer-info-vec))))))
(defun package-build--package-buffer-info-vec () (defun package-build--desc-from-library (name version commit files &optional type)
"Return a vector of package info. (let* ((file (concat name ".el"))
`package-buffer-info' returns a vector in older Emacs versions, (file (or (car (rassoc file files)) file)))
and a cl struct in Emacs HEAD. This wrapper normalises the results." (and (file-exists-p file)
(let ((desc (package-buffer-info)) (with-temp-buffer
(keywords (lm-keywords-list))) (insert-file-contents file)
(if (fboundp 'package-desc-create) (package-desc-from-define
(let ((extras (package-desc-extras desc))) name version
(when (and keywords (not (assq :keywords extras))) (or (save-excursion
(push (cons :keywords keywords) extras)) (goto-char (point-min))
(vector (package-desc-name desc) (and (re-search-forward
(package-desc-reqs desc) "^;;; [^ ]*\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"
(package-desc-summary desc) nil t)
(package-desc-version desc) (match-string-no-properties 1)))
extras)) "No description available.")
(let ((homepage (package-build--lm-homepage)) (when-let ((require-lines (lm-header-multiline "package-requires")))
extras) (package--prepare-dependencies
(when keywords (push (cons :keywords keywords) extras)) (package-read-from-string (mapconcat #'identity require-lines " "))))
(when homepage (push (cons :url homepage) extras)) :kind (or type 'single)
(vector (aref desc 0) :url (lm-homepage)
(aref desc 1) :keywords (lm-keywords-list)
(aref desc 2) :maintainer (lm-maintainer)
(aref desc 3) :authors (lm-authors)
extras))))) :commit commit)))))
(defun package-build--get-pkg-file-info (file-path) (defun package-build--desc-from-package (name version commit files)
"Get a vector of package info from \"-pkg.el\" file FILE-PATH." (let* ((file (concat name "-pkg.el"))
(when (file-exists-p file-path) (file (or (car (rassoc file files))
(let ((package-def (with-temp-buffer file)))
(insert-file-contents file-path) (and (or (file-exists-p file)
(read (current-buffer))))) (file-exists-p (setq file (concat file ".in"))))
(if (eq 'define-package (car package-def)) (let ((form (with-temp-buffer
(let* ((pkgfile-info (cdr package-def)) (insert-file-contents file)
(descr (nth 2 pkgfile-info)) (read (current-buffer)))))
(rest-plist (cl-subseq pkgfile-info (min 4 (length pkgfile-info)))) (unless (eq (car form) 'define-package)
(extras (let (alist) (error "No define-package found in %s" file))
(while rest-plist (pcase-let*
(unless (memq (car rest-plist) '(:kind :archive)) ((`(,_ ,_ ,_ ,summary ,deps . ,extra) form)
(let ((value (cadr rest-plist))) (deps (eval deps))
(when value (alt-desc (package-build--desc-from-library
(push (cons (car rest-plist) name version nil files))
(if (eq (car-safe value) 'quote) (alt (and alt-desc (package-desc-extras alt-desc))))
(cadr value) (when (string-match "[\r\n]" summary)
value)) (error "Illegal multi-line package description in %s" file))
alist)))) (package-desc-from-define
(setq rest-plist (cddr rest-plist))) name version
alist))) (if (string-empty-p summary)
(when (string-match "[\r\n]" descr) (or (and alt-desc (package-desc-summary alt-desc))
(error "Illegal multi-line package description in %s" file-path)) "No description available.")
(vector summary)
(nth 0 pkgfile-info) (mapcar (pcase-lambda (`(,pkg ,ver))
(mapcar (unless (symbolp pkg)
(lambda (elt) (error "Invalid package name in dependency: %S" pkg))
(unless (symbolp (car elt)) (list pkg ver))
(error "Invalid package name in dependency: %S" (car elt))) deps)
(list (car elt) (version-to-list (cadr elt)))) :kind 'tar
(eval (nth 3 pkgfile-info))) :url (or (alist-get :url extra)
descr (alist-get :homepage extra)
(nth 1 pkgfile-info) (alist-get :url alt))
extras)) :keywords (or (alist-get :keywords extra)
(error "No define-package found in %s" file-path))))) (alist-get :keywords alt))
:maintainer (or (alist-get :maintainer extra)
(alist-get :maintainer alt))
:authors (or (alist-get :authors extra)
(alist-get :authors alt))
:commit commit))))))
(defun package-build--merge-package-info (pkg-info name version commit) (defun package-build--write-archive-entry (desc)
"Return a version of PKG-INFO updated with NAME, VERSION and info from CONFIG. (with-temp-file
If PKG-INFO is nil, an empty one is created." (expand-file-name (concat (package-desc-full-name desc) ".entry")
(let ((merged (or (copy-sequence pkg-info) package-build-archive-dir)
(vector name nil "No description available." version nil)))) (pp (cons (package-desc-name desc)
(aset merged 0 name) (vector (package-desc-version desc)
(aset merged 3 version) (package-desc-reqs desc)
(when commit (package-desc-summary desc)
(aset merged 4 (cons (cons :commit commit) (elt pkg-info 4)))) (package-desc-kind desc)
merged)) (package-desc-extras desc)))
(current-buffer))))
(defun package-build--write-archive-entry (rcp pkg-info type)
(let ((entry (package-build--archive-entry rcp pkg-info type)))
(with-temp-file (package-build--archive-entry-file entry)
(print entry (current-buffer)))))
(defmethod package-build--get-commit ((rcp package-git-recipe))
(ignore-errors
(package-build--run-process-match
"\\(.*\\)"
(package-recipe--working-tree rcp)
"git" "rev-parse" "HEAD")))
(defmethod package-build--get-commit ((rcp package-hg-recipe))
(ignore-errors
(package-build--run-process-match
"changeset:[[:space:]]+[[:digit:]]+:\\([[:xdigit:]]+\\)"
(package-recipe--working-tree rcp)
"hg" "log" "--debug" "--limit=1")))
(defun package-build--archive-entry (rcp pkg-info type)
(let ((name (intern (aref pkg-info 0)))
(requires (aref pkg-info 1))
(desc (or (aref pkg-info 2) "No description available."))
(version (aref pkg-info 3))
(extras (and (> (length pkg-info) 4)
(aref pkg-info 4))))
(cons name
(vector (version-to-list version)
requires
desc
type
extras))))
(defun package-build--artifact-file (archive-entry)
"Return the path of the file in which the package for ARCHIVE-ENTRY is stored."
(let* ((name (car archive-entry))
(pkg-info (cdr archive-entry))
(version (package-version-join (aref pkg-info 0)))
(flavour (aref pkg-info 3)))
(expand-file-name
(format "%s-%s.%s" name version (if (eq flavour 'single) "el" "tar"))
package-build-archive-dir)))
(defun package-build--archive-entry-file (archive-entry)
"Return the path of the file in which the package for ARCHIVE-ENTRY is stored."
(let* ((name (car archive-entry))
(pkg-info (cdr archive-entry))
(version (package-version-join (aref pkg-info 0))))
(expand-file-name
(format "%s-%s.entry" name version)
package-build-archive-dir)))
;;; File Specs ;;; File Specs
@ -595,7 +582,7 @@ for ALLOW-EMPTY to prevent this error."
(let ((default-directory dir) (let ((default-directory dir)
(prefix (if subdir (format "%s/" subdir) "")) (prefix (if subdir (format "%s/" subdir) ""))
(lst)) (lst))
(dolist (entry specs lst) (dolist (entry specs)
(setq lst (setq lst
(if (consp entry) (if (consp entry)
(if (eq :exclude (car entry)) (if (eq :exclude (car entry))
@ -612,7 +599,6 @@ for ALLOW-EMPTY to prevent this error."
t))) t)))
(nconc (nconc
lst (mapcar (lambda (f) lst (mapcar (lambda (f)
(let ((destname)))
(cons f (cons f
(concat prefix (concat prefix
(replace-regexp-in-string (replace-regexp-in-string
@ -640,65 +626,15 @@ for ALLOW-EMPTY to prevent this error."
(package-recipe--working-tree rcp) (package-recipe--working-tree rcp)
(package-build--config-file-list rcp)))) (package-build--config-file-list rcp))))
;;; Info Manuals
(defun package-build--generate-info-files (files source-dir target-dir)
"Create .info files from any .texi files listed in FILES.
The source and destination file paths are expanded in SOURCE-DIR
and TARGET-DIR respectively.
Any of the original .texi(nfo) files found in TARGET-DIR are
deleted."
(dolist (spec files)
(let* ((source-file (car spec))
(source-path (expand-file-name source-file source-dir))
(dest-file (cdr spec))
(info-path (expand-file-name
(concat (file-name-sans-extension dest-file) ".info")
target-dir)))
(when (string-match ".texi\\(nfo\\)?$" source-file)
(unless (file-exists-p info-path)
(ignore-errors
(package-build--run-process
(file-name-directory source-path) nil
"makeinfo" source-path "-o" info-path)
(package-build--message "Created %s" info-path)))
(package-build--message "Removing %s"
(expand-file-name dest-file target-dir))
(delete-file (expand-file-name dest-file target-dir))))))
(defun package-build--generate-dir-file (files target-dir)
"Create dir file from any .info files listed in FILES in TARGET-DIR."
(dolist (spec files)
(let* ((source-file (car spec))
(dest-file (cdr spec))
(info-path (expand-file-name
(concat (file-name-sans-extension dest-file) ".info")
target-dir)))
(when (and (or (string-match ".info$" source-file)
(string-match ".texi\\(nfo\\)?$" source-file))
(file-exists-p info-path))
(ignore-errors
(package-build--run-process
nil nil
"install-info"
(concat "--dir=" (expand-file-name "dir" target-dir))
info-path))))))
;;; Building Utilities
(defun package-build--copy-package-files (files source-dir target-dir) (defun package-build--copy-package-files (files source-dir target-dir)
"Copy FILES from SOURCE-DIR to TARGET-DIR. "Copy FILES from SOURCE-DIR to TARGET-DIR.
FILES is a list of (SOURCE . DEST) relative filepath pairs." FILES is a list of (SOURCE . DEST) relative filepath pairs."
(package-build--message (package-build--message
"Copying files (->) and directories (=>)\n from %s\n to %s" "Copying files (->) and directories (=>)\n from %s\n to %s"
source-dir target-dir) source-dir target-dir)
(dolist (elt files) (pcase-dolist (`(,src . ,dst) files)
(let* ((src (car elt)) (let ((src* (expand-file-name src source-dir))
(dst (cdr elt)) (dst* (expand-file-name dst target-dir)))
(src* (expand-file-name src source-dir))
(dst* (expand-file-name dst target-dir)))
(make-directory (file-name-directory dst*) t) (make-directory (file-name-directory dst*) t)
(cond ((file-regular-p src*) (cond ((file-regular-p src*)
(package-build--message (package-build--message
@ -709,14 +645,12 @@ FILES is a list of (SOURCE . DEST) relative filepath pairs."
" %s %s => %s" (if (equal src dst) " " "!") src dst) " %s %s => %s" (if (equal src dst) " " "!") src dst)
(copy-directory src* dst*)))))) (copy-directory src* dst*))))))
(defconst package-build--this-file load-file-name) ;;; Commands
;;; Building
;;;###autoload ;;;###autoload
(defun package-build-archive (name &optional dump-archive-contents) (defun package-build-archive (name &optional dump-archive-contents)
"Build a package archive for the package named NAME. "Build a package archive for the package named NAME.
if DUMP-ARCHIVE-CONTENTS is non-nil, the updated archive contents If DUMP-ARCHIVE-CONTENTS is non-nil, the updated archive contents
are subsequently dumped." are subsequently dumped."
(interactive (list (package-recipe-read-name) t)) (interactive (list (package-recipe-read-name) t))
(let ((start-time (current-time)) (let ((start-time (current-time))
@ -733,8 +667,7 @@ are subsequently dumped."
(package-build--message "Built %s in %.3fs, finished at %s" (package-build--message "Built %s in %.3fs, finished at %s"
name name
(float-time (time-since start-time)) (float-time (time-since start-time))
(current-time-string)) (current-time-string))))
(list name version)))
(when dump-archive-contents (when dump-archive-contents
(package-build-dump-archive-contents))) (package-build-dump-archive-contents)))
@ -758,97 +691,52 @@ in `package-build-archive-dir'."
(error "Unable to check out repository for %s" name)) (error "Unable to check out repository for %s" name))
((= 1 (length files)) ((= 1 (length files))
(package-build--build-single-file-package (package-build--build-single-file-package
rcp version commit (caar files) source-dir)) rcp version commit files source-dir))
((< 1 (length files)) ((< 1 (length files))
(package-build--build-multi-file-package (package-build--build-multi-file-package
rcp version commit files source-dir)) rcp version commit files source-dir))
(t (error "Unable to find files matching recipe patterns"))))) (t (error "Unable to find files matching recipe patterns")))))
(define-obsolete-function-alias 'package-build-package 'package-build--package (defun package-build--build-single-file-package (rcp version commit files source-dir)
"Package-Build 2.0.
The purpose of this alias is to get Cask working again.
This alias is only a temporary kludge and is going to be removed
again. It will likely be replaced by a function with the same
name but a different signature.
Do not use this alias elsewhere.")
(defun package-build--build-single-file-package (rcp version commit file source-dir)
(let* ((name (oref rcp name)) (let* ((name (oref rcp name))
(pkg-source (expand-file-name file source-dir)) (file (caar files))
(pkg-target (expand-file-name (source (expand-file-name file source-dir))
(concat name "-" version ".el") (target (expand-file-name (concat name "-" version ".el")
package-build-archive-dir)) package-build-archive-dir))
(pkg-info (package-build--merge-package-info (desc (let ((default-directory source-dir))
(package-build--get-package-info pkg-source) (package-build--desc-from-library
name version commit))) name version commit files))))
(unless (string-equal (downcase (concat name ".el")) (unless (string-equal (downcase (concat name ".el"))
(downcase (file-name-nondirectory pkg-source))) (downcase file))
(error "Single file %s does not match package name %s" (error "Single file %s does not match package name %s" file name))
(file-name-nondirectory pkg-source) name)) (copy-file source target t)
(copy-file pkg-source pkg-target t)
(let ((enable-local-variables nil) (let ((enable-local-variables nil)
(make-backup-files nil)) (make-backup-files nil))
(with-current-buffer (find-file pkg-target) (with-current-buffer (find-file target)
(package-build--update-or-insert-header "Package-Commit" commit) (package-build--update-or-insert-header "Package-Commit" commit)
(package-build--update-or-insert-header "Package-Version" version) (package-build--update-or-insert-header "Package-Version" version)
(package-build--ensure-ends-here-line pkg-source) (package-build--ensure-ends-here-line source)
(write-file pkg-target nil) (write-file target nil)
(condition-case err
(package-build--package-buffer-info-vec)
(error
(package-build--message "Warning: %S" err)))
(kill-buffer))) (kill-buffer)))
(package-build--write-pkg-readme (package-build--write-pkg-readme name files source-dir)
package-build-archive-dir (package-build--write-archive-entry desc)))
(package-build--find-package-commentary pkg-source)
name)
(package-build--write-archive-entry rcp pkg-info 'single)))
(defun package-build--build-multi-file-package (rcp version commit files source-dir) (defun package-build--build-multi-file-package (rcp version commit files source-dir)
(let* ((name (oref rcp name)) (let* ((name (oref rcp name))
(tmp-dir (file-name-as-directory (make-temp-file name t)))) (tmp-dir (file-name-as-directory (make-temp-file name t))))
(unwind-protect (unwind-protect
(let* ((pkg-dir-name (concat name "-" version)) (let* ((target (expand-file-name (concat name "-" version) tmp-dir))
(pkg-tmp-dir (expand-file-name pkg-dir-name tmp-dir)) (desc (let ((default-directory source-dir))
(pkg-file (concat name "-pkg.el")) (or (package-build--desc-from-package
(pkg-file-source (or (car (rassoc pkg-file files)) name version commit files)
pkg-file)) (package-build--desc-from-library
(file-source (concat name ".el")) name version commit files 'tar)))))
(pkg-source (or (car (rassoc file-source files)) (package-build--copy-package-files files source-dir target)
file-source)) (package-build--write-pkg-file desc target)
(pkg-info (package-build--merge-package-info (package-build--generate-info-files files source-dir target)
(let ((default-directory source-dir)) (package-build--create-tar name version tmp-dir)
(or (package-build--get-pkg-file-info pkg-file-source) (package-build--write-pkg-readme name files source-dir)
;; Some packages provide NAME-pkg.el.in (package-build--write-archive-entry desc))
(package-build--get-pkg-file-info
(expand-file-name (concat pkg-file ".in")
(file-name-directory pkg-source)))
(package-build--get-package-info pkg-source)))
name version commit)))
(package-build--copy-package-files files source-dir pkg-tmp-dir)
(package-build--write-pkg-file (expand-file-name
pkg-file
(file-name-as-directory pkg-tmp-dir))
pkg-info)
(package-build--generate-info-files files source-dir pkg-tmp-dir)
(package-build--generate-dir-file files pkg-tmp-dir)
(let ((default-directory tmp-dir))
(package-build--create-tar
(expand-file-name (concat name "-" version ".tar")
package-build-archive-dir)
pkg-dir-name))
(let ((default-directory source-dir))
(package-build--write-pkg-readme
package-build-archive-dir
(package-build--find-package-commentary pkg-source)
name))
(package-build--write-archive-entry rcp pkg-info 'tar))
(delete-directory tmp-dir t nil)))) (delete-directory tmp-dir t nil))))
;;;###autoload ;;;###autoload
@ -899,27 +787,31 @@ Do not use this alias elsewhere.")
If non-nil, then store the archive contents in FILE instead of in If non-nil, then store the archive contents in FILE instead of in
the \"archive-contents\" file inside `package-build-archive-dir'. the \"archive-contents\" file inside `package-build-archive-dir'.
If PRETTY-PRINT is non-nil, then pretty-print insted of using one If PRETTY-PRINT is non-nil, then pretty-print instead of using one
line per entry." line per entry."
(let (entries) (let (entries)
(dolist (file (directory-files package-build-archive-dir t ".*\.entry$")) (dolist (file (sort (directory-files package-build-archive-dir t ".*\.entry$")
;; Sort more recently-build packages first
(lambda (f1 f2)
(let ((default-directory package-build-archive-dir))
(file-newer-than-file-p f1 f2)))))
(let* ((entry (with-temp-buffer (let* ((entry (with-temp-buffer
(insert-file-contents file) (insert-file-contents file)
(read (current-buffer)))) (read (current-buffer))))
(name (car entry)) (name (car entry))
(other-entry (assq name entries))) (newer-entry (assq name entries)))
(if (not (file-exists-p (expand-file-name (symbol-name name) (if (not (file-exists-p (expand-file-name (symbol-name name)
package-build-recipes-dir))) package-build-recipes-dir)))
(package-build--remove-archive-files entry) (package-build--remove-archive-files entry)
(when other-entry ;; Prefer the more-recently-built package, which may not
(when (version-list-< (elt (cdr entry) 0) ;; necessarily have the highest version number, e.g. if
(elt (cdr other-entry) 0)) ;; commit histories were changed.
;; Swap so that other-entry has the smallest version. (if newer-entry
(cl-rotatef other-entry entry)) (package-build--remove-archive-files entry)
(package-build--remove-archive-files other-entry) (push entry entries)))))
(setq entries (remove other-entry entries))) (setq entries (sort entries (lambda (a b)
(add-to-list 'entries entry)))) (string< (symbol-name (car a))
(setq entries (nreverse entries)) (symbol-name (car b))))))
(with-temp-file (with-temp-file
(or file (or file
(expand-file-name "archive-contents" package-build-archive-dir)) (expand-file-name "archive-contents" package-build-archive-dir))
@ -935,8 +827,6 @@ line per entry."
(insert ")")))) (insert ")"))))
entries)) entries))
(defalias 'package-build--archive-entries 'package-build-dump-archive-contents)
(defun package-build--remove-archive-files (archive-entry) (defun package-build--remove-archive-files (archive-entry)
"Remove the entry and archive file for ARCHIVE-ENTRY." "Remove the entry and archive file for ARCHIVE-ENTRY."
(package-build--message "Removing archive: %s-%s" (package-build--message "Removing archive: %s-%s"
@ -949,11 +839,28 @@ line per entry."
(when (file-exists-p file) (when (file-exists-p file)
(delete-file file)))) (delete-file file))))
;;; Exporting Data as Json (defun package-build--artifact-file (archive-entry)
"Return the path of the file in which the package for ARCHIVE-ENTRY is stored."
(pcase-let* ((`(,name . ,desc) archive-entry)
(version (package-version-join (aref desc 0)))
(flavour (aref desc 3)))
(expand-file-name
(format "%s-%s.%s" name version (if (eq flavour 'single) "el" "tar"))
package-build-archive-dir)))
(defun package-build--archive-entry-file (archive-entry)
"Return the path of the file in which the package for ARCHIVE-ENTRY is stored."
(pcase-let* ((`(,name . ,desc) archive-entry)
(version (package-version-join (aref desc 0))))
(expand-file-name
(format "%s-%s.entry" name version)
package-build-archive-dir)))
;;; Json Exports
(defun package-build-recipe-alist-as-json (file) (defun package-build-recipe-alist-as-json (file)
"Dump the recipe list to FILE as json." "Dump the recipe list to FILE as json."
(interactive) (interactive "FDump json to file: ")
(with-temp-file file (with-temp-file file
(insert (insert
(json-encode (json-encode
@ -973,12 +880,7 @@ line per entry."
(defun package-build--pkg-info-for-json (info) (defun package-build--pkg-info-for-json (info)
"Convert INFO into a data structure which will serialize to JSON in the desired shape." "Convert INFO into a data structure which will serialize to JSON in the desired shape."
(let ((ver (elt info 0)) (pcase-let ((`(,ver ,deps ,desc ,type . (,props)) (append info nil)))
(deps (elt info 1))
(desc (elt info 2))
(type (elt info 3))
(props (and (> (length info) 4)
(elt info 4))))
(list :ver ver (list :ver ver
:deps (cl-mapcan (lambda (dep) :deps (cl-mapcan (lambda (dep)
(list (intern (format ":%s" (car dep))) (list (intern (format ":%s" (car dep)))
@ -1020,19 +922,11 @@ line per entry."
(with-temp-file file (with-temp-file file
(insert (json-encode (package-build--archive-alist-for-json))))) (insert (json-encode (package-build--archive-alist-for-json)))))
;;; Backports
(defun package-build--lm-homepage (&optional file)
"Return the homepage in file FILE, or current buffer if FILE is nil.
This is a copy of `lm-homepage', which first appeared in Emacs 24.4."
(let ((page (lm-with-file file
(lm-header "\\(?:x-\\)?\\(?:homepage\\|url\\)"))))
(if (and page (string-match "^<.+>$" page))
(substring page 1 -1)
page)))
;;; _ ;;; _
(define-obsolete-function-alias 'package-build--archive-entries
'package-build-dump-archive-contents "Package-Build 3.0")
(provide 'package-build) (provide 'package-build)
;; For the time being just require all libraries that contain code ;; For the time being just require all libraries that contain code
@ -1040,5 +934,10 @@ This is a copy of `lm-homepage', which first appeared in Emacs 24.4."
(require 'package-build-badges) (require 'package-build-badges)
(require 'package-recipe-mode) (require 'package-recipe-mode)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End: ;; End:
;;; package-build.el ends here ;;; package-build.el ends here

15
core/libs/package-recipe-mode.el
View File

@ -1,7 +1,8 @@
;;; package-recipe-mode.el --- Minor mode for editing package recipes ;;; package-recipe-mode.el --- Minor mode for editing package recipes -*- lexical-binding: t -*-
;; Copyright (C) 2011-2013 Donald Ephraim Curtis <dcurtis@milkbox.net> ;; Copyright (C) 2011-2020 Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Copyright (C) 2012-2014 Steve Purcell <steve@sanityinc.com> ;; Copyright (C) 2012-2020 Steve Purcell <steve@sanityinc.com>
;; Copyright (C) 2016-2020 Jonas Bernoulli <jonas@bernoul.li>
;; Copyright (C) 2009 Phil Hagelberg <technomancy@gmail.com> ;; Copyright (C) 2009 Phil Hagelberg <technomancy@gmail.com>
;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net> ;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
@ -55,8 +56,7 @@
(interactive (interactive
(list (read-string "Package name: ") (list (read-string "Package name: ")
(intern (completing-read "Fetcher: " (intern (completing-read "Fetcher: "
(list "git" "github" "gitlab" (list "git" "github" "gitlab" "hg")
"hg" "bitbucket")
nil t nil nil "github")))) nil t nil nil "github"))))
(let ((recipe-file (expand-file-name name package-build-recipes-dir))) (let ((recipe-file (expand-file-name name package-build-recipes-dir)))
(when (file-exists-p recipe-file) (when (file-exists-p recipe-file)
@ -101,5 +101,10 @@
(assq (intern name) (package-build-archive-alist))))))) (assq (intern name) (package-build-archive-alist)))))))
(provide 'package-recipe-mode) (provide 'package-recipe-mode)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End: ;; End:
;;; package-recipe-mode.el ends here ;;; package-recipe-mode.el ends here

19
core/libs/package-recipe.el
View File

@ -1,6 +1,6 @@
;;; package-recipe.el --- Package recipes as EIEIO objects -*- lexical-binding: t -*- ;;; package-recipe.el --- Package recipes as EIEIO objects -*- lexical-binding: t -*-
;; Copyright (C) 2018 Jonas Bernoulli ;; Copyright (C) 2018-2020 Jonas Bernoulli
;; Author: Jonas Bernoulli <jonas@bernoul.li> ;; Author: Jonas Bernoulli <jonas@bernoul.li>
@ -51,15 +51,18 @@
(old-names :initarg :old-names :initform nil)) (old-names :initarg :old-names :initform nil))
:abstract t) :abstract t)
(defmethod package-recipe--working-tree ((rcp package-recipe)) (cl-defmethod package-recipe--working-tree ((rcp package-recipe))
(file-name-as-directory (file-name-as-directory
(expand-file-name (oref rcp name) package-build-working-dir))) (expand-file-name (oref rcp name) package-build-working-dir)))
(defmethod package-recipe--upstream-url ((rcp package-recipe)) (cl-defmethod package-recipe--upstream-url ((rcp package-recipe))
(or (oref rcp url) (or (oref rcp url)
(format (oref rcp url-format) (format (oref rcp url-format)
(oref rcp repo)))) (oref rcp repo))))
(cl-defmethod package-recipe--fetcher ((rcp package-recipe))
(substring (symbol-name (eieio-object-class rcp)) 8 -7))
;;;; Git ;;;; Git
(defclass package-git-recipe (package-recipe) (defclass package-git-recipe (package-recipe)
@ -82,10 +85,6 @@
\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} \ \\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} \
[0-9]\\{2\\}:[0-9]\\{2\\}\\( [+-][0-9]\\{4\\}\\)?\\)"))) [0-9]\\{2\\}:[0-9]\\{2\\}\\( [+-][0-9]\\{4\\}\\)?\\)")))
(defclass package-bitbucket-recipe (package-hg-recipe)
((url-format :initform "https://bitbucket.org/%s")
(repopage-format :initform "https://bitbucket.org/%s")))
;;; Interface ;;; Interface
(defun package-recipe-recipes () (defun package-recipe-recipes ()
@ -138,7 +137,7 @@ file is invalid, then raise an error."
(cl-assert (memq thing all-keys) nil "Unknown keyword %S" thing))) (cl-assert (memq thing all-keys) nil "Unknown keyword %S" thing)))
(let ((fetcher (plist-get plist :fetcher))) (let ((fetcher (plist-get plist :fetcher)))
(cl-assert fetcher nil ":fetcher is missing") (cl-assert fetcher nil ":fetcher is missing")
(if (memq fetcher '(github gitlab bitbucket)) (if (memq fetcher '(github gitlab))
(progn (progn
(cl-assert (plist-get plist :repo) ":repo is missing") (cl-assert (plist-get plist :repo) ":repo is missing")
(cl-assert (not (plist-get plist :url)) ":url is redundant")) (cl-assert (not (plist-get plist :url)) ":url is redundant"))
@ -159,5 +158,9 @@ file is invalid, then raise an error."
;;; _ ;;; _
(provide 'package-recipe) (provide 'package-recipe)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End: ;; End:
;;; package-recipe.el ends here ;;; package-recipe.el ends here

13
core/libs/page-break-lines.el
View File

@ -1,4 +1,4 @@
;;; page-break-lines.el --- Display ^L page breaks as tidy horizontal lines ;;; page-break-lines.el --- Display ^L page breaks as tidy horizontal lines -*- lexical-binding: t -*-
;; Copyright (C) 2012-2015 Steve Purcell ;; Copyright (C) 2012-2015 Steve Purcell
@ -105,9 +105,6 @@ horizontal line of `page-break-lines-char' characters."
:group 'page-break-lines :group 'page-break-lines
(page-break-lines--update-display-tables)) (page-break-lines--update-display-tables))
;;;###autoload
(define-obsolete-function-alias 'turn-on-page-break-lines-mode 'page-break-lines-mode "2018-07-24")
(dolist (hook '(window-configuration-change-hook (dolist (hook '(window-configuration-change-hook
window-size-change-functions window-size-change-functions
after-setting-font-hook after-setting-font-hook
@ -130,7 +127,8 @@ its display table will be modified as necessary."
(set-face-attribute 'page-break-lines nil :height default-height) (set-face-attribute 'page-break-lines nil :height default-height)
(let* ((cwidth (char-width page-break-lines-char)) (let* ((cwidth (char-width page-break-lines-char))
(wwidth-pix (- (window-width nil t) (wwidth-pix (- (window-width nil t)
(if (bound-and-true-p display-line-numbers) (if (and (bound-and-true-p display-line-numbers)
(fboundp 'line-number-display-width))
(line-number-display-width t) (line-number-display-width t)
0))) 0)))
(width (- (/ wwidth-pix (frame-char-width) cwidth) (width (- (/ wwidth-pix (frame-char-width) cwidth)
@ -170,5 +168,10 @@ When `major-mode' is listed in `page-break-lines-modes', then
(provide 'page-break-lines) (provide 'page-break-lines)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: t
;; End: ;; End:
;;; page-break-lines.el ends here ;;; page-break-lines.el ends here

354
core/libs/quelpa.el
View File

@ -4,10 +4,10 @@
;; Copyright 2014-2015, Vasilij Schneidermann <v.schneidermann@gmail.com> ;; Copyright 2014-2015, Vasilij Schneidermann <v.schneidermann@gmail.com>
;; Author: steckerhalter ;; Author: steckerhalter
;; URL: https://framagit.org/steckerhalter/quelpa ;; URL: https://github.com/quelpa/quelpa
;; Version: 0.0.1 ;; Version: 1.0
;; Package-Requires: ((emacs "24.3")) ;; Package-Requires: ((emacs "25.1"))
;; Keywords: package management build source elpa ;; Keywords: tools package management build source elpa
;; This file is not part of GNU Emacs. ;; This file is not part of GNU Emacs.
@ -32,11 +32,11 @@
;; built on-the-fly directly from source. ;; built on-the-fly directly from source.
;; See the README for more info: ;; See the README for more info:
;; https://framagit.org/steckerhalter/quelpa/blob/master/README.md ;; https://github.com/quelpa/quelpa/blob/master/README.org
;;; Requirements: ;;; Requirements:
;; Emacs 24.3.1 ;; Emacs 25.1
;;; Code: ;;; Code:
@ -45,6 +45,7 @@
(require 'url-parse) (require 'url-parse)
(require 'package) (require 'package)
(require 'lisp-mnt) (require 'lisp-mnt)
(eval-when-compile (require 'subr-x))
;; --- customs / variables --------------------------------------------------- ;; --- customs / variables ---------------------------------------------------
@ -64,6 +65,13 @@ the `:upgrade' argument."
:group 'quelpa :group 'quelpa
:type 'boolean) :type 'boolean)
(defcustom quelpa-autoremove-p t
"When non-nil, automatically remove old packages after upgrading.
The global value can be overridden for each package by supplying the
`:autoremove' argument."
:group 'quelpa
:type 'boolean)
(defcustom quelpa-verbose t (defcustom quelpa-verbose t
"When non-nil, `quelpa' prints log messages." "When non-nil, `quelpa' prints log messages."
:group 'quelpa :group 'quelpa
@ -153,46 +161,20 @@ quelpa cache."
:type '(choice (const :tag "Don't shallow clone" nil) :type '(choice (const :tag "Don't shallow clone" nil)
(integer :tag "Depth"))) (integer :tag "Depth")))
(defcustom quelpa-upgrade-interval nil
"Interval in days for `quelpa-upgrade-all-maybe'."
:group 'quelpa
:type 'integer)
(defvar quelpa-initialized-p nil (defvar quelpa-initialized-p nil
"Non-nil when quelpa has been initialized.") "Non-nil when quelpa has been initialized.")
(defvar quelpa-cache nil (defvar quelpa-cache nil
"The `quelpa' command stores processed pkgs/recipes in the cache.") "The `quelpa' command stores processed pkgs/recipes in the cache.")
(defvar quelpa-recipe '(quelpa :url "https://framagit.org/steckerhalter/quelpa.git" :fetcher git) (defvar quelpa-recipe '(quelpa :repo "quelpa/quelpa" :fetcher github)
"The recipe for quelpa.") "The recipe for quelpa.")
;; --- compatibility for legacy `package.el' in Emacs 24.3 -------------------
(defun quelpa-setup-package-structs ()
"Setup the struct `package-desc' when not available.
`package-desc-from-legacy' is provided to convert the legacy
vector desc into a valid PACKAGE-DESC."
(unless (functionp 'package-desc-p)
(cl-defstruct
(package-desc
(:constructor
;; convert legacy package desc into PACKAGE-DESC
package-desc-from-legacy
(pkg-info kind
&aux
(name (intern (aref pkg-info 0)))
(version (version-to-list (aref pkg-info 3)))
(summary (if (string= (aref pkg-info 2) "")
"No description available."
(aref pkg-info 2)))
(reqs (aref pkg-info 1))
(kind kind))))
name
version
(summary "No description available.")
reqs
kind
archive
dir
extras
signed)))
;; --- package building ------------------------------------------------------ ;; --- package building ------------------------------------------------------
(defun quelpa-package-type (file) (defun quelpa-package-type (file)
@ -217,14 +199,9 @@ On error return nil."
(`tar (insert-file-contents-literally file) (`tar (insert-file-contents-literally file)
(tar-mode) (tar-mode)
(with-no-warnings (with-no-warnings
(if (help-function-arglist 'package-tar-file-info) (package-tar-file-info))))))))
;; legacy `package-tar-file-info' requires an arg (when (package-desc-p desc)
(package-tar-file-info file) desc)))
(package-tar-file-info)))))))))
(pcase desc
((pred package-desc-p) desc)
((pred vectorp) (when (fboundp 'package-desc-from-legacy)
(package-desc-from-legacy desc kind))))))
(defun quelpa-archive-file-name (archive-entry) (defun quelpa-archive-file-name (archive-entry)
"Return the path of the file in which the package for ARCHIVE-ENTRY is stored." "Return the path of the file in which the package for ARCHIVE-ENTRY is stored."
@ -236,23 +213,46 @@ On error return nil."
(format "%s-%s.%s" name version (if (eq flavour 'single) "el" "tar")) (format "%s-%s.%s" name version (if (eq flavour 'single) "el" "tar"))
quelpa-packages-dir))) quelpa-packages-dir)))
(defun quelpa-version>-p (name version) (defconst quelpa--min-ver '(0 -10) "Smallest possible version.")
"Return non-nil if VERSION of pkg with NAME is newer than what is currently installed." (defun quelpa-version-cmp (name version op)
(not (or (not version) "Return non-nil if version of pkg with NAME and VERSION satisfies OP.
(let ((pkg-desc (cdr (assq name package-alist)))) OP is taking two version list and comparing."
(and pkg-desc (let ((ver (if version (version-to-list version) quelpa--min-ver))
(version-list-<= (pkg-ver
(version-to-list version) (or (when-let ((pkg-desc (cdr (assq name package-alist)))
(package-desc-version (car pkg-desc))))) (pkg-ver (package-desc-version (car pkg-desc))))
;; Also check built-in packages. pkg-ver)
(package-built-in-p name (version-to-list version))))) (alist-get name package--builtin-versions)
quelpa--min-ver)))
(funcall op ver pkg-ver)))
(defmacro quelpa-version>-p (name version)
"Return non-nil if VERSION of pkg with NAME is newer than what is currently installed."
`(quelpa-version-cmp ,name ,version (lambda (o1 o2) (not (version-list-<= o1 o2)))))
(defmacro quelpa-version<-p (name version)
"Return non-nil if VERSION of pkg with NAME is older than what is currently installed."
`(quelpa-version-cmp ,name ,version 'version-list-<))
(defmacro quelpa-version=-p (name version)
"Return non-nil if VERSION of pkg with NAME is same which what is currently installed."
`(quelpa-version-cmp ,name ,version 'version-list-=))
(defun quelpa--package-installed-p (package &optional min-version)
"Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed.
Like `package-installed-p' but properly check for built-in package even when all
packages are not initialized."
(or (package-installed-p package (or min-version quelpa--min-ver))
(package-built-in-p package (or min-version quelpa--min-ver))))
(defvar quelpa--override-version-check nil)
(defun quelpa-checkout (rcp dir) (defun quelpa-checkout (rcp dir)
"Return the version of the new package given a RCP and DIR. "Return the version of the new package given a RCP and DIR.
Return nil if the package is already installed and should not be upgraded." Return nil if the package is already installed and should not be upgraded."
(pcase-let ((`(,name . ,config) rcp) (pcase-let ((`(,name . ,config) rcp)
(quelpa-build-stable quelpa-stable-p)) (quelpa-build-stable quelpa-stable-p)
(unless (or (and (assq name package-alist) (not quelpa-upgrade-p)) (quelpa--override-version-check quelpa--override-version-check))
(unless (or (and (quelpa--package-installed-p name) (not quelpa-upgrade-p))
(and (not config) (and (not config)
(quelpa-message t "no recipe found for package `%s'" name))) (quelpa-message t "no recipe found for package `%s'" name)))
(let ((version (condition-case-unless-debug err (let ((version (condition-case-unless-debug err
@ -260,8 +260,14 @@ Return nil if the package is already installed and should not be upgraded."
(error (error
(error "Failed to checkout `%s': `%s'" (error "Failed to checkout `%s': `%s'"
name (error-message-string err)))))) name (error-message-string err))))))
(when (quelpa-version>-p name version) (cond
version))))) ((and quelpa--override-version-check
(quelpa-version=-p name version))
(setq version (concat version ".1"))
version)
((or quelpa--override-version-check
(quelpa-version>-p name version))
version))))))
(defun quelpa-build (rcp) (defun quelpa-build (rcp)
"Build a package from the given recipe RCP. "Build a package from the given recipe RCP.
@ -273,13 +279,18 @@ already and should not be upgraded etc)."
(let* ((name (car rcp)) (let* ((name (car rcp))
(build-dir (expand-file-name (symbol-name name) quelpa-build-dir)) (build-dir (expand-file-name (symbol-name name) quelpa-build-dir))
(version (quelpa-checkout rcp build-dir))) (version (quelpa-checkout rcp build-dir)))
(when version (prog1
(quelpa-archive-file-name (if version
(quelpa-build-package (symbol-name name) (quelpa-archive-file-name
version (quelpa-build-package (symbol-name name)
(quelpa-build--config-file-list (cdr rcp)) version
build-dir (quelpa-build--config-file-list (cdr rcp))
quelpa-packages-dir))))) build-dir
quelpa-packages-dir))
(quelpa-build--message "Newer package has been installed. Not upgrading.")
nil)
(when (fboundp 'package--quickstart-maybe-refresh)
(package--quickstart-maybe-refresh)))))
;; --- package-build.el integration ------------------------------------------ ;; --- package-build.el integration ------------------------------------------
@ -884,14 +895,15 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository."
(let* ((repo (plist-get config :url)) (let* ((repo (plist-get config :url))
(remote (or (plist-get config :remote) "origin")) (remote (or (plist-get config :remote) "origin"))
(commit (or (plist-get config :commit) (commit (or (plist-get config :commit)
(let ((branch (plist-get config :branch))) (when-let ((branch (plist-get config :branch)))
(when branch (concat remote "/" branch))))) (concat remote "/" branch))))
(depth (or (plist-get config :depth) quelpa-git-clone-depth)) (depth (or (plist-get config :depth) quelpa-git-clone-depth))
(force (plist-get config :force)) (force (plist-get config :force))
(use-current-ref (plist-get config :use-current-ref))) (use-current-ref (plist-get config :use-current-ref)))
(when (string-match (rx bos "file://" (group (1+ anything))) repo) (when (string-match (rx bos "file://" (group (1+ anything))) repo)
;; Expand local file:// URLs ;; Expand local file:// URLs
(setq repo (expand-file-name (match-string 1 repo)))) (setq repo (expand-file-name (match-string 1 repo))))
(setq quelpa--override-version-check use-current-ref)
(with-current-buffer (get-buffer-create "*quelpa-build-checkout*") (with-current-buffer (get-buffer-create "*quelpa-build-checkout*")
(goto-char (point-max)) (goto-char (point-max))
(cond (cond
@ -910,8 +922,8 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository."
(when (and depth (not (plist-get config :commit))) (when (and depth (not (plist-get config :commit)))
`("--depth" ,(int-to-string depth) `("--depth" ,(int-to-string depth)
"--no-single-branch")) "--no-single-branch"))
(let ((branch (plist-get config :branch))) (when-let ((branch (plist-get config :branch)))
(when branch `("--branch" ,branch))))))) `("--branch" ,branch))))))
(if quelpa-build-stable (if quelpa-build-stable
(let* ((min-bound (goto-char (point-max))) (let* ((min-bound (goto-char (point-max)))
(tag-version (tag-version
@ -973,6 +985,11 @@ This will perform an checkout or a reset if FORCE."
(let ((url (format "https://github.com/%s.git" (plist-get config :repo)))) (let ((url (format "https://github.com/%s.git" (plist-get config :repo))))
(quelpa-build--checkout-git name (plist-put (copy-sequence config) :url url) dir))) (quelpa-build--checkout-git name (plist-put (copy-sequence config) :url url) dir)))
(defun quelpa-build--checkout-github-ssh (name config dir)
"Check package NAME with config CONFIG out of github into DIR."
(let ((url (format "git@github.com:%s.git" (plist-get config :repo))))
(quelpa-build--checkout-git name (plist-put (copy-sequence config) :url url) dir)))
(defun quelpa-build--checkout-gitlab (name config dir) (defun quelpa-build--checkout-gitlab (name config dir)
"Check package NAME with config CONFIG out of gitlab into DIR." "Check package NAME with config CONFIG out of gitlab into DIR."
(let ((url (format "https://gitlab.com/%s.git" (plist-get config :repo)))) (let ((url (format "https://gitlab.com/%s.git" (plist-get config :repo))))
@ -1251,13 +1268,12 @@ Tests and sets variable `quelpa--tar-type' if not already set."
(extras (let (alist) (extras (let (alist)
(while rest-plist (while rest-plist
(unless (memq (car rest-plist) '(:kind :archive)) (unless (memq (car rest-plist) '(:kind :archive))
(let ((value (cadr rest-plist))) (when-let ((value (cadr rest-plist)))
(when value (push (cons (car rest-plist)
(push (cons (car rest-plist) (if (eq (car-safe value) 'quote)
(if (eq (car-safe value) 'quote) (cadr value)
(cadr value) value))
value)) alist)))
alist))))
(setq rest-plist (cddr rest-plist))) (setq rest-plist (cddr rest-plist)))
alist))) alist)))
(when (string-match "[\r\n]" descr) (when (string-match "[\r\n]" descr)
@ -1451,12 +1467,8 @@ and a cl struct in Emacs HEAD. This wrapper normalises the results."
(package-desc-summary desc) (package-desc-summary desc)
(package-desc-version desc) (package-desc-version desc)
extras)) extras))
;; The regexp and the processing is taken from `lm-homepage' in Emacs 24.4 (let ((homepage (lm-homepage))
(let* ((page (lm-header "\\(?:x-\\)?\\(?:homepage\\|url\\)")) extras)
(homepage (if (and page (string-match "^<.+>$" page))
(substring page 1 -1)
page))
extras)
(when keywords (push (cons :keywords keywords) extras)) (when keywords (push (cons :keywords keywords) extras))
(when homepage (push (cons :url homepage) extras)) (when homepage (push (cons :url homepage) extras))
(vector (aref desc 0) (vector (aref desc 0)
@ -1671,15 +1683,22 @@ Return t in each case."
;; default value anyways ;; default value anyways
(when (plist-member (cdr cache-item) :stable) (when (plist-member (cdr cache-item) :stable)
(setq quelpa-stable-p (plist-get (cdr cache-item) :stable))) (setq quelpa-stable-p (plist-get (cdr cache-item) :stable)))
(when (and quelpa-stable-p (not (plist-get (cdr cache-item) :stable))) (when (and quelpa-stable-p
(plist-member (cdr cache-item) :stable)
(not (plist-get (cdr cache-item) :stable)))
(setf (cdr (last cache-item)) '(:stable t)))) (setf (cdr (last cache-item)) '(:stable t))))
(defun quelpa-checkout-melpa () ;;;###autoload
(defun quelpa-checkout-melpa (&optional force)
"Fetch or update the melpa source code from Github. "Fetch or update the melpa source code from Github.
If there is no error return non-nil. If there is no error return non-nil.
If there is an error but melpa is already checked out return non-nil. If there is an error but melpa is already checked out return non-nil.
If there is an error and no existing checkout return nil." If there is an error and no existing checkout return nil.
(or (and (null quelpa-update-melpa-p)
When FORCE is non-nil we will always update MELPA regrdless of
`quelpa-update-melpa-p`."
(interactive "p")
(or (and (not (or force quelpa-update-melpa-p))
(file-exists-p (expand-file-name ".git" quelpa-melpa-dir))) (file-exists-p (expand-file-name ".git" quelpa-melpa-dir)))
(condition-case err (condition-case err
(quelpa-build--checkout-git (quelpa-build--checkout-git
@ -1693,7 +1712,7 @@ If there is an error and no existing checkout return nil."
Return the recipe if it exists, otherwise nil." Return the recipe if it exists, otherwise nil."
(cl-loop for store in quelpa-melpa-recipe-stores (cl-loop for store in quelpa-melpa-recipe-stores
if (stringp store) if (stringp store)
for file = (assoc-string name (directory-files store nil "^[^\.]+")) for file = (assoc-string name (directory-files store nil "^[^.].*$"))
when file when file
return (with-temp-buffer return (with-temp-buffer
(insert-file-contents-literally (insert-file-contents-literally
@ -1712,9 +1731,10 @@ Return non-nil if quelpa has been initialized properly."
(unless (file-exists-p dir) (make-directory dir t))) (unless (file-exists-p dir) (make-directory dir t)))
(unless quelpa-initialized-p (unless quelpa-initialized-p
(quelpa-read-cache) (quelpa-read-cache)
(quelpa-setup-package-structs) (when (and quelpa-checkout-melpa-p
(if quelpa-checkout-melpa-p (not (quelpa-checkout-melpa)))
(unless (quelpa-checkout-melpa) (throw 'quit nil))) (throw 'quit nil))
(unless package-alist (package-load-all-descriptors))
(setq quelpa-initialized-p t)) (setq quelpa-initialized-p t))
t)) t))
@ -1728,9 +1748,9 @@ Return non-nil if quelpa has been initialized properly."
"Given recipe or package name ARG, return an alist '(NAME . RCP). "Given recipe or package name ARG, return an alist '(NAME . RCP).
If RCP cannot be found it will be set to nil" If RCP cannot be found it will be set to nil"
(pcase arg (pcase arg
(`(,a . nil) (quelpa-get-melpa-recipe (car arg))) (`(,name) (quelpa-get-melpa-recipe name))
(`(,a . ,_) arg) (`(,name . ,_) arg)
((pred symbolp) (quelpa-get-melpa-recipe arg)))) (name (quelpa-get-melpa-recipe name))))
(defun quelpa-parse-plist (plist) (defun quelpa-parse-plist (plist)
"Parse the optional PLIST argument of `quelpa'. "Parse the optional PLIST argument of `quelpa'.
@ -1742,13 +1762,18 @@ If t, `quelpa' tries to do an upgrade.
:stable :stable
If t, `quelpa' tries building the stable version of a package." If t, `quelpa' tries building the stable version of a package.
:autoremove
If t, `quelpa' tries to remove obsoleted packages."
(while plist (while plist
(let ((key (car plist)) (let ((key (car plist))
(value (cadr plist))) (value (cadr plist)))
(pcase key (pcase key
(:upgrade (setq quelpa-upgrade-p value)) (:upgrade (setq quelpa-upgrade-p value))
(:stable (setq quelpa-stable-p value)))) (:stable (setq quelpa-stable-p value))
(:autoremove (setq quelpa-autoremove-p value))))
(setq plist (cddr plist)))) (setq plist (cddr plist))))
(defun quelpa-package-install-file (file) (defun quelpa-package-install-file (file)
@ -1770,43 +1795,67 @@ So here we replace that with `insert-file-contents' for non-tar files."
(defun quelpa-package-install (arg &rest plist) (defun quelpa-package-install (arg &rest plist)
"Build and install package from ARG (a recipe or package name). "Build and install package from ARG (a recipe or package name).
PLIST is a plist that may modify the build and/or fetch process. PLIST is a plist that may modify the build and/or fetch process.
If the package has dependencies recursively call this function to install them." If the package has dependencies recursively call this function to install them.
Return new package version."
(let* ((rcp (quelpa-arg-rcp arg)) (let* ((rcp (quelpa-arg-rcp arg))
(file (when rcp (quelpa-build (append rcp plist))))) (file (when rcp (quelpa-build (append rcp plist)))))
(when file (when file
(let* ((pkg-desc (quelpa-get-package-desc file)) (let* ((pkg-desc (quelpa-get-package-desc file))
(requires (package-desc-reqs pkg-desc))) (requires (package-desc-reqs pkg-desc))
(ver (package-desc-version pkg-desc)))
(when requires (when requires
(mapc (lambda (req) (mapc (lambda (req)
(unless (or (equal 'emacs (car req)) (unless (or (equal 'emacs (car req))
(package-installed-p (car req) (cadr req))) (quelpa--package-installed-p (car req) (cadr req)))
(quelpa-package-install (car req)))) (quelpa-package-install (car req))))
requires)) requires))
(quelpa-package-install-file file))))) (quelpa-package-install-file file)
ver))))
(defun quelpa-interactive-candidate () (defun quelpa-interactive-candidate ()
"Query the user for a recipe and return the name." "Query the user for a recipe and return the name or recipe."
(when (quelpa-setup-p) (when (quelpa-setup-p)
(let ((recipes (cl-loop (let* ((recipes (cl-loop
for store in quelpa-melpa-recipe-stores for store in quelpa-melpa-recipe-stores
if (stringp store) if (stringp store)
;; this regexp matches all files except dotfiles ;; this regexp matches all files except dotfiles
append (directory-files store nil "^[^.].+$") append (directory-files store nil "^[^.].*$")
else if (listp store) else if (listp store)
append store))) append store))
(intern (completing-read "Choose MELPA recipe: " (recipe (completing-read "Choose MELPA recipe: " recipes nil t)))
recipes nil t))))) (pcase (assoc-string recipe recipes)
((and re (pred stringp)) (intern re))
(re re)))))
(defun quelpa--delete-obsoleted-package (name &optional new-version)
"Delete obsoleted packages with name NAME.
With NEW-VERSION, will delete obsoleted packages that are not in same
version."
(when-let ((all-pkgs (alist-get name package-alist))
(new-pkg-version (or new-version
(package-desc-version (car all-pkgs)))))
(with-demoted-errors "Error deleting package: %S"
(mapc (lambda (pkg-desc)
(unless (equal (package-desc-version pkg-desc)
new-pkg-version)
(let ((inhibit-message t))
(package-delete pkg-desc 'force))))
all-pkgs))
;; Only packages with same version remained. Just pick the first one.
(when-let (all-pkgs (alist-get name package-alist))
(setf (cdr all-pkgs) nil))))
;; --- public interface ------------------------------------------------------ ;; --- public interface ------------------------------------------------------
;;;###autoload ;;;###autoload
(defun quelpa-expand-recipe (recipe-name) (defun quelpa-expand-recipe (recipe)
"Expand a given RECIPE-NAME into full recipe. "Expand a given RECIPE into full recipe.
If called interactively, let the user choose a recipe name and If called interactively, let the user choose a recipe name and
insert the result into the current buffer." insert the result into the current buffer."
(interactive (list (quelpa-interactive-candidate))) (interactive (list (quelpa-interactive-candidate)))
(when (quelpa-setup-p) (when (quelpa-setup-p)
(let* ((recipe (quelpa-get-melpa-recipe recipe-name))) (let* ((recipe (if (listp recipe) recipe
(quelpa-get-melpa-recipe recipe))))
(when recipe (when recipe
(if (called-interactively-p 'any) (if (called-interactively-p 'any)
(prin1 recipe (current-buffer))) (prin1 recipe (current-buffer)))
@ -1828,15 +1877,11 @@ the `quelpa' command has been run in the current Emacs session.
With prefix FORCE, packages will all be upgraded discarding local changes." With prefix FORCE, packages will all be upgraded discarding local changes."
(interactive "P") (interactive "P")
(when (quelpa-setup-p) (when (quelpa-setup-p)
(let ((quelpa-upgrade-p t)) (when quelpa-self-upgrade-p
(when quelpa-self-upgrade-p (quelpa-self-upgrade))
(quelpa-self-upgrade)) (mapc (lambda (rcp)
(setq quelpa-cache (quelpa-upgrade rcp (when force 'force)))
(cl-remove-if-not #'package-installed-p quelpa-cache :key #'car)) quelpa-cache)))
(mapc (lambda (item)
(when (package-installed-p (car (quelpa-arg-rcp item)))
(quelpa item :force force)))
quelpa-cache))))
;;;###autoload ;;;###autoload
(defun quelpa-upgrade (rcp &optional action) (defun quelpa-upgrade (rcp &optional action)
@ -1846,21 +1891,22 @@ Optionally, ACTION can be passed for non-interactive call with value of:
- `local' (or \\[universal-argument] \\[universal-argument] \\[quelpa-upgrade]) - `local' (or \\[universal-argument] \\[universal-argument] \\[quelpa-upgrade])
for upgrade using current working tree." for upgrade using current working tree."
(interactive (interactive
(when (quelpa-setup-p) (let ((prefix (prefix-numeric-value current-prefix-arg)))
(let* ((quelpa-melpa-recipe-stores (list quelpa-cache)) (list nil
(name (quelpa-interactive-candidate)) (cond ((eq prefix 4) 'force)
(prefix (prefix-numeric-value current-prefix-arg))) ((eq prefix 16) 'local)))))
(list (assoc name quelpa-cache) (when (quelpa-setup-p)
(cond ((eq prefix 4) 'force) (let* ((rcp (or rcp
((eq prefix 16) 'local)))))) (let ((quelpa-melpa-recipe-stores
(when rcp (list (cl-remove-if-not #'quelpa--package-installed-p
(let ((quelpa-upgrade-p t) quelpa-cache :key #'car))))
(current-prefix-arg nil) (quelpa-interactive-candidate))))
(config (cond ((eq action 'force) `(:force t)) (quelpa-upgrade-p t)
((eq action 'local) `(:use-current-ref t))))) (current-prefix-arg nil)
(setq quelpa-cache (config (append (cond ((eq action 'force) `(:force t))
(cl-remove-if-not #'package-installed-p quelpa-cache :key #'car)) ((eq action 'local) `(:use-current-ref t)))
(when (package-installed-p (car (quelpa-arg-rcp rcp))) `(:autoremove ,quelpa-autoremove-p))))
(when (quelpa--package-installed-p (car (quelpa-arg-rcp rcp)))
(apply #'quelpa rcp config))))) (apply #'quelpa rcp config)))))
;;;###autoload ;;;###autoload
@ -1875,20 +1921,40 @@ When `quelpa' is called interactively with a prefix argument (e.g
\\[universal-argument] \\[quelpa]) it will try to upgrade the \\[universal-argument] \\[quelpa]) it will try to upgrade the
given package even if the global var `quelpa-upgrade-p' is set to given package even if the global var `quelpa-upgrade-p' is set to
nil." nil."
(interactive (list nil))
(interactive (list (quelpa-interactive-candidate)))
(run-hooks 'quelpa-before-hook) (run-hooks 'quelpa-before-hook)
(when (quelpa-setup-p) ;if init fails we do nothing (when (quelpa-setup-p) ;if init fails we do nothing
(let* ((quelpa-upgrade-p (if current-prefix-arg t quelpa-upgrade-p)) ;shadow `quelpa-upgrade-p' (let* ((arg (or arg
(let ((quelpa-melpa-recipe-stores
`(,@quelpa-melpa-recipe-stores ,quelpa-cache)))
(quelpa-interactive-candidate))))
(quelpa-upgrade-p (if current-prefix-arg t quelpa-upgrade-p)) ;shadow `quelpa-upgrade-p'
(quelpa-stable-p quelpa-stable-p) ;shadow `quelpa-stable-p' (quelpa-stable-p quelpa-stable-p) ;shadow `quelpa-stable-p'
(cache-item (if (symbolp arg) (list arg) arg))) (quelpa-autoremove-p (if current-prefix-arg quelpa-autoremove-p nil))
(cache-item (quelpa-arg-rcp arg)))
(quelpa-parse-plist plist) (quelpa-parse-plist plist)
(quelpa-parse-stable cache-item) (quelpa-parse-stable cache-item)
(apply #'quelpa-package-install arg plist) (when-let ((ver (apply #'quelpa-package-install arg plist)))
(quelpa-update-cache cache-item))) (when quelpa-autoremove-p
(quelpa--delete-obsoleted-package (car cache-item) ver))
(quelpa-update-cache cache-item))))
(quelpa-shutdown) (quelpa-shutdown)
(run-hooks 'quelpa-after-hook)) (run-hooks 'quelpa-after-hook))
;;;###autoload
(defun quelpa-upgrade-all-maybe (&optional force)
"Run `quelpa-upgrade-all' if at least `quelpa-upgrade-interval' days have passed since the last run.
With prefix FORCE, packages will all be upgraded discarding local changes."
(interactive "P")
(when quelpa-upgrade-interval
(let ((timestamp (expand-file-name "last_upgrade" quelpa-dir)))
(when (or (not (file-exists-p timestamp))
(> (- (time-to-seconds) ; Current time - modification time.
(time-to-seconds (nth 5 (file-attributes timestamp))))
(* 60 60 24 quelpa-upgrade-interval)))
(quelpa-upgrade-all force)
(write-region "" nil timestamp)))))
(provide 'quelpa) (provide 'quelpa)
;;; quelpa.el ends here ;;; quelpa.el ends here

43
core/libs/spacemacs-theme/spacemacs-common.el
View File

@ -109,6 +109,7 @@ to 'auto, tags may not be properly aligned. "
(bg2 (if (eq variant 'dark) (if (true-color-p) "#212026" "#1c1c1c") (if (true-color-p) "#efeae9" "#e4e4e4"))) (bg2 (if (eq variant 'dark) (if (true-color-p) "#212026" "#1c1c1c") (if (true-color-p) "#efeae9" "#e4e4e4")))
(bg3 (if (eq variant 'dark) (if (true-color-p) "#100a14" "#121212") (if (true-color-p) "#e3dedd" "#d0d0d0"))) (bg3 (if (eq variant 'dark) (if (true-color-p) "#100a14" "#121212") (if (true-color-p) "#e3dedd" "#d0d0d0")))
(bg4 (if (eq variant 'dark) (if (true-color-p) "#0a0814" "#080808") (if (true-color-p) "#d2ceda" "#bcbcbc"))) (bg4 (if (eq variant 'dark) (if (true-color-p) "#0a0814" "#080808") (if (true-color-p) "#d2ceda" "#bcbcbc")))
(bg-alt (if (eq variant 'dark) (if (true-color-p) "#42444a" "#353535") (if (true-color-p) "#efeae9" "#e4e4e4")))
(border (if (eq variant 'dark) (if (true-color-p) "#5d4d7a" "#111111") (if (true-color-p) "#b3b9be" "#b3b9be"))) (border (if (eq variant 'dark) (if (true-color-p) "#5d4d7a" "#111111") (if (true-color-p) "#b3b9be" "#b3b9be")))
(cblk (if (eq variant 'dark) (if (true-color-p) "#cbc1d5" "#b2b2b2") (if (true-color-p) "#655370" "#5f5f87"))) (cblk (if (eq variant 'dark) (if (true-color-p) "#cbc1d5" "#b2b2b2") (if (true-color-p) "#655370" "#5f5f87")))
(cblk-bg (if (eq variant 'dark) (if (true-color-p) "#2f2b33" "#262626") (if (true-color-p) "#e8e3f0" "#ffffff"))) (cblk-bg (if (eq variant 'dark) (if (true-color-p) "#2f2b33" "#262626") (if (true-color-p) "#e8e3f0" "#ffffff")))
@ -207,6 +208,7 @@ to 'auto, tags may not be properly aligned. "
`(tooltip ((,class (:background ,ttip-sl :foreground ,base :bold nil :italic nil :underline nil)))) `(tooltip ((,class (:background ,ttip-sl :foreground ,base :bold nil :italic nil :underline nil))))
`(vertical-border ((,class (:foreground ,border)))) `(vertical-border ((,class (:foreground ,border))))
`(warning ((,class (:foreground ,war)))) `(warning ((,class (:foreground ,war))))
`(widget-button-pressed ((,class (:foreground ,green))))
;;;;; ace-window ;;;;; ace-window
`(aw-leading-char-face ((,class (:foreground ,func :weight bold :height 2.0 :box (:line-width 1 :color ,keyword :style released-button))))) `(aw-leading-char-face ((,class (:foreground ,func :weight bold :height 2.0 :box (:line-width 1 :color ,keyword :style released-button)))))
@ -252,9 +254,9 @@ to 'auto, tags may not be properly aligned. "
`(centaur-tabs-selected ((,class (:background ,bg1 :foreground ,base :weight bold)))) `(centaur-tabs-selected ((,class (:background ,bg1 :foreground ,base :weight bold))))
`(centaur-tabs-unselected ((,class (:background ,bg2 :foreground ,base-dim :weight light)))) `(centaur-tabs-unselected ((,class (:background ,bg2 :foreground ,base-dim :weight light))))
`(centaur-tabs-selected-modified ((,class (:background ,bg1 `(centaur-tabs-selected-modified ((,class (:background ,bg1
:foreground ,blue :weight bold)))) :foreground ,blue :weight bold))))
`(centaur-tabs-unselected-modified ((,class (:background ,bg2 :weight light `(centaur-tabs-unselected-modified ((,class (:background ,bg2 :weight light
:foreground ,blue)))) :foreground ,blue))))
`(centaur-tabs-active-bar-face ((,class (:background ,keyword)))) `(centaur-tabs-active-bar-face ((,class (:background ,keyword))))
`(centaur-tabs-modified-marker-selected ((,class (:inherit 'centaur-tabs-selected :foreground,keyword)))) `(centaur-tabs-modified-marker-selected ((,class (:inherit 'centaur-tabs-selected :foreground,keyword))))
`(centaur-tabs-modified-marker-unselected ((,class (:inherit 'centaur-tabs-unselected :foreground,keyword)))) `(centaur-tabs-modified-marker-unselected ((,class (:inherit 'centaur-tabs-unselected :foreground,keyword))))
@ -280,7 +282,7 @@ to 'auto, tags may not be properly aligned. "
`(company-tooltip ((,class (:background ,ttip-bg :foreground ,ttip)))) `(company-tooltip ((,class (:background ,ttip-bg :foreground ,ttip))))
`(company-tooltip-annotation ((,class (:foreground ,type)))) `(company-tooltip-annotation ((,class (:foreground ,type))))
`(company-tooltip-common ((,class (:background ,ttip-bg :foreground ,keyword)))) `(company-tooltip-common ((,class (:background ,ttip-bg :foreground ,keyword))))
`(company-tooltip-common-selection ((,class (:foreground ,base)))) `(company-tooltip-common-selection ((,class (:foreground ,keyword))))
`(company-tooltip-mouse ((,class (:inherit highlight)))) `(company-tooltip-mouse ((,class (:inherit highlight))))
`(company-tooltip-search ((,class (:inherit match)))) `(company-tooltip-search ((,class (:inherit match))))
`(company-tooltip-selection ((,class (:background ,ttip-sl :foreground ,base)))) `(company-tooltip-selection ((,class (:background ,ttip-sl :foreground ,base))))
@ -299,9 +301,9 @@ to 'auto, tags may not be properly aligned. "
`(diff-removed ((,class :background nil :foreground ,red :extend t))) `(diff-removed ((,class :background nil :foreground ,red :extend t)))
;;;;; diff-hl ;;;;; diff-hl
`(diff-hl-change ((,class :background ,blue-bg-s :foreground ,blue))) `(diff-hl-insert ((,class :background ,green :foreground ,green)))
`(diff-hl-delete ((,class :background ,red-bg-s :foreground ,red))) `(diff-hl-delete ((,class :background ,red :foreground ,red)))
`(diff-hl-insert ((,class :background ,green-bg-s :foreground ,green))) `(diff-hl-change ((,class :background ,blue :foreground ,blue)))
;;;;; dired ;;;;; dired
`(dired-directory ((,class (:foreground ,keyword :background ,bg1 :inherit bold)))) `(dired-directory ((,class (:foreground ,keyword :background ,bg1 :inherit bold))))
@ -481,8 +483,8 @@ to 'auto, tags may not be properly aligned. "
;;;;; git-gutter-fr ;;;;; git-gutter-fr
`(git-gutter-fr:added ((,class (:foreground ,green :inherit bold)))) `(git-gutter-fr:added ((,class (:foreground ,green :inherit bold))))
`(git-gutter-fr:deleted ((,class (:foreground ,war :inherit bold)))) `(git-gutter-fr:deleted ((,class (:foreground ,red :inherit bold))))
`(git-gutter-fr:modified ((,class (:foreground ,keyword :inherit bold)))) `(git-gutter-fr:modified ((,class (:foreground ,blue :inherit bold))))
;;;;; git-timemachine ;;;;; git-timemachine
`(git-timemachine-minibuffer-detail-face ((,class (:foreground ,blue :inherit bold :background ,blue-bg)))) `(git-timemachine-minibuffer-detail-face ((,class (:foreground ,blue :inherit bold :background ,blue-bg))))
@ -553,7 +555,10 @@ to 'auto, tags may not be properly aligned. "
`(highlight-indentation-face ((,class (:background ,comment-bg)))) `(highlight-indentation-face ((,class (:background ,comment-bg))))
;;;;; highlight-symbol ;;;;; highlight-symbol
`(highlight-symbol-face ((,class (:background ,bg2)))) `(highlight-symbol-face ((,class (:background ,bg-alt))))
;;;;; highlight-thing
`(highlight-thing ((,class (:background ,bg-alt))))
;;;;; hydra ;;;;; hydra
`(hydra-face-blue ((,class (:foreground ,blue)))) `(hydra-face-blue ((,class (:foreground ,blue))))
@ -584,7 +589,7 @@ to 'auto, tags may not be properly aligned. "
`(ivy-minibuffer-match-face-3 ((,class (:foreground ,head4 :underline t)))) `(ivy-minibuffer-match-face-3 ((,class (:foreground ,head4 :underline t))))
`(ivy-minibuffer-match-face-4 ((,class (:foreground ,head3 :underline t)))) `(ivy-minibuffer-match-face-4 ((,class (:foreground ,head3 :underline t))))
`(ivy-remote ((,class (:foreground ,cyan)))) `(ivy-remote ((,class (:foreground ,cyan))))
;;;;; ivy-posframe ;;;;; ivy-posframe
`(ivy-posframe ((,class (:background ,bg3)))) `(ivy-posframe ((,class (:background ,bg3))))
@ -618,6 +623,12 @@ to 'auto, tags may not be properly aligned. "
;;;;; linum-relative ;;;;; linum-relative
`(linum-relative-current-face ((,class (:foreground ,comp)))) `(linum-relative-current-face ((,class (:foreground ,comp))))
;;;;; lsp
`(lsp-ui-doc-background ((,class (:background ,bg2))))
`(lsp-ui-doc-header ((,class (:foreground ,head1 :background ,head1-bg))))
`(lsp-ui-sideline-code-action ((,class (:foreground ,comp))))
;;;;; magit ;;;;; magit
`(magit-blame-culprit ((,class :background ,yellow-bg :foreground ,yellow))) `(magit-blame-culprit ((,class :background ,yellow-bg :foreground ,yellow)))
`(magit-blame-date ((,class :background ,yellow-bg :foreground ,green))) `(magit-blame-date ((,class :background ,yellow-bg :foreground ,green)))
@ -784,6 +795,12 @@ to 'auto, tags may not be properly aligned. "
`(outline-7 ((,class (:inherit org-level-7)))) `(outline-7 ((,class (:inherit org-level-7))))
`(outline-8 ((,class (:inherit org-level-8)))) `(outline-8 ((,class (:inherit org-level-8))))
;;;;; parinfer
`(parinfer-pretty-parens:dim-paren-face ((,class (:foreground ,base-dim))))
;;;;; parinfer-rust-mode
`(parinfer-rust-dim-parens ((,class (:foreground ,base-dim))))
;;;;; perspective ;;;;; perspective
`(persp-selected-face ((,class (:inherit bold :foreground ,func)))) `(persp-selected-face ((,class (:inherit bold :foreground ,func))))
@ -913,6 +930,12 @@ to 'auto, tags may not be properly aligned. "
`(treemacs-git-modified-face ((,class (:foreground ,blue :background ,blue-bg)))) `(treemacs-git-modified-face ((,class (:foreground ,blue :background ,blue-bg))))
`(treemacs-git-untracked-face ((,class (:foreground ,aqua :background ,aqua-bg)))) `(treemacs-git-untracked-face ((,class (:foreground ,aqua :background ,aqua-bg))))
;;;;; tab-bar-mode
`(tab-bar ((,class (:foreground ,base :background ,bg1))))
`(tab-bar-tab ((,class (:foreground ,base :background ,bg1 :weight bold))))
`(tab-line ((,class (:foreground ,base :background ,bg1))))
`(tab-bar-tab-inactive ((,class (:foreground ,base-dim :background ,bg2 :weight light))))
;;;;; web-mode ;;;;; web-mode
`(web-mode-builtin-face ((,class (:inherit ,font-lock-builtin-face)))) `(web-mode-builtin-face ((,class (:inherit ,font-lock-builtin-face))))
`(web-mode-comment-face ((,class (:inherit ,font-lock-comment-face)))) `(web-mode-comment-face ((,class (:inherit ,font-lock-comment-face))))

9
core/libs/spinner.el
View File

@ -155,6 +155,7 @@ Each spinner can override this value.")
The list of possible built-in spinner types is given by the The list of possible built-in spinner types is given by the
`spinner-types' variable, but you can also use your own (see `spinner-types' variable, but you can also use your own (see
below). below).
If TYPE is nil, the frames of this spinner are given by the first If TYPE is nil, the frames of this spinner are given by the first
element of `spinner-types'. element of `spinner-types'.
If TYPE is a symbol, it specifies an element of `spinner-types'. If TYPE is a symbol, it specifies an element of `spinner-types'.
@ -195,16 +196,20 @@ own spinner animations."
(defun spinner-create (&optional type buffer-local fps delay) (defun spinner-create (&optional type buffer-local fps delay)
"Create a spinner of the given TYPE. "Create a spinner of the given TYPE.
The possible TYPEs are described in `spinner--type-to-frames'. The possible TYPEs are described in `spinner--type-to-frames'.
FPS, if given, is the number of desired frames per second. FPS, if given, is the number of desired frames per second.
Default is `spinner-frames-per-second'. Default is `spinner-frames-per-second'.
If BUFFER-LOCAL is non-nil, the spinner will be automatically If BUFFER-LOCAL is non-nil, the spinner will be automatically
deactivated if the buffer is killed. If BUFFER-LOCAL is a deactivated if the buffer is killed. If BUFFER-LOCAL is a
buffer, use that instead of current buffer. buffer, use that instead of current buffer.
When started, in order to function properly, the spinner runs a When started, in order to function properly, the spinner runs a
timer which periodically calls `force-mode-line-update' in the timer which periodically calls `force-mode-line-update' in the
curent buffer. If BUFFER-LOCAL was set at creation time, then curent buffer. If BUFFER-LOCAL was set at creation time, then
`force-mode-line-update' is called in that buffer instead. When `force-mode-line-update' is called in that buffer instead. When
the spinner is stopped, the timer is deactivated. the spinner is stopped, the timer is deactivated.
DELAY, if given, is the number of seconds to wait after starting DELAY, if given, is the number of seconds to wait after starting
the spinner before actually displaying it. It is safe to cancel the spinner before actually displaying it. It is safe to cancel
the spinner before this time, in which case it won't display at the spinner before this time, in which case it won't display at
@ -273,16 +278,20 @@ simply activate it. This method is designed for minor modes, so
they can use the spinner as part of their lighter by doing: they can use the spinner as part of their lighter by doing:
'(:eval (spinner-print THE-SPINNER)) '(:eval (spinner-print THE-SPINNER))
To stop this spinner, call `spinner-stop' on it. To stop this spinner, call `spinner-stop' on it.
If TYPE-OR-OBJECT is anything else, a buffer-local spinner is If TYPE-OR-OBJECT is anything else, a buffer-local spinner is
created with this type, and it is displayed in the created with this type, and it is displayed in the
`mode-line-process' of the buffer it was created it. Both `mode-line-process' of the buffer it was created it. Both
TYPE-OR-OBJECT and FPS are passed to `make-spinner' (which see). TYPE-OR-OBJECT and FPS are passed to `make-spinner' (which see).
To stop this spinner, call `spinner-stop' in the same buffer. To stop this spinner, call `spinner-stop' in the same buffer.
Either way, the return value is a function which can be called Either way, the return value is a function which can be called
anywhere to stop this spinner. You can also call `spinner-stop' anywhere to stop this spinner. You can also call `spinner-stop'
in the same buffer where the spinner was created. in the same buffer where the spinner was created.
FPS, if given, is the number of desired frames per second. FPS, if given, is the number of desired frames per second.
Default is `spinner-frames-per-second'. Default is `spinner-frames-per-second'.
DELAY, if given, is the number of seconds to wait until actually DELAY, if given, is the number of seconds to wait until actually
displaying the spinner. It is safe to cancel the spinner before displaying the spinner. It is safe to cancel the spinner before
this time, in which case it won't display at all." this time, in which case it won't display at all."