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
;; Author: Wilfred Hughes <me@wilfred.me.uk>
;; Version: 2.2
;; Version: 2.3
;; Keywords: hash table, hash map, hash
;; Package-Requires: ((dash "2.12.0"))
@ -29,6 +29,9 @@
;;; Code:
(require 'dash)
(require 'gv)
(eval-when-compile
(require 'inline))
(defmacro ht (&rest pairs)
"Create a hash table with the key-value pairs given.
@ -44,13 +47,22 @@ Keys are compared with `equal'.
,@assignments
,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.
TEST indicates the function used to compare the hash
keys. Default is `equal'. It can be `eq', `eql', `equal' or a
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)
"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
keys. Default is `equal'. It can be `eq', `eql', `equal' or a
user-supplied test created via `define-hash-table-test'."
(declare (side-effect-free t))
(let ((h (ht-create test)))
;; the first key-value pair in an alist gets precedence, so we
;; 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
keys. Default is `equal'. It can be `eq', `eql', `equal' or a
user-supplied test created via `define-hash-table-test'."
(declare (side-effect-free t))
(let ((h (ht-create test)))
(dolist (pair (-partition 2 plist) h)
(dolist (pair (nreverse (-partition 2 plist)) h)
(let ((key (car pair))
(value (cadr pair)))
(ht-set! h key value)))))
(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.
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.
The lookup for each key should return another hash table, except
for the final key, which may return any value."
(if (cdr keys)
(apply #'ht-get* (ht-get table (car keys)) (cdr keys))
(ht-get table (car keys))))
(declare (side-effect-free t))
(inline-letevals (table keys)
(inline-quote
(prog1 ,table
(while ,keys
(setf ,table (ht-get table (pop ,keys))))))))
(defsubst ht-set! (table key value)
"Associate KEY in TABLE with VALUE."
(puthash key value table)
nil)
(defalias 'ht-set 'ht-set!)
(put 'ht-get* 'compiler-macro
(lambda (_ table &rest keys)
(--reduce-from `(ht-get ,acc ,it) table keys)))
(defun ht-update! (table 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)
merged))
(defsubst ht-remove! (table key)
(define-inline ht-remove! (table key)
"Remove KEY from TABLE."
(remhash key table))
(inline-quote (remhash ,key ,table)))
(defalias 'ht-remove 'ht-remove!)
(defsubst ht-clear! (table)
(define-inline ht-clear! (table)
"Remove all keys from TABLE."
(clrhash table)
nil)
(inline-quote
(prog1 nil
(clrhash ,table))))
(defalias 'ht-clear 'ht-clear!)
@ -145,19 +166,23 @@ FUNCTION is called with two arguments, KEY and VALUE."
(defmacro ht-amap (form table)
"Anaphoric version of `ht-map'.
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))
(defun ht-keys (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)
"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)
"Return a list of two-element lists '(key value) from TABLE."
(declare (side-effect-free t))
(ht-amap (list key value) table))
(defalias 'ht-each 'maphash
@ -172,6 +197,7 @@ variables key and value bound."
(defun ht-select-keys (table keys)
"Return a copy of TABLE with only the specified KEYS."
(declare (side-effect-free t))
(let (result)
(setq result (make-hash-table :test (hash-table-test table)))
(dolist (key keys result)
@ -187,13 +213,15 @@ inverse of `ht<-plist'. The following is not guaranteed:
\(let ((data '(a b c d)))
(equalp data
(ht->plist (ht<-plist data))))"
(declare (side-effect-free t))
(apply 'append (ht-items table)))
(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)."
(copy-hash-table table))
(declare (side-effect-free t))
(inline-quote (copy-hash-table ,table)))
(defun ht->alist (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))))
(equalp data
(ht->alist (ht<-alist data))))"
(declare (side-effect-free t))
(ht-amap (cons key value) table))
(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)
(defun ht-contains? (table key)
(define-inline ht-contains? (table 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?)
(defsubst ht-size (table)
(define-inline ht-size (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."
(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)
"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)
"Return t if TABLE1 and TABLE2 have the same keys and values.
Does not compare equality predicates."
(declare (side-effect-free t))
(let ((keys1 (ht-keys table1))
(keys2 (ht-keys table2))
(sentinel (make-symbol "ht-sentinel")))

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

@ -5,7 +5,6 @@
;; Author: Steven Degutis
;; Maintainer: Christopher Reichert <creichert07@gmail.com>
;; Version: 1.0.0
;; Package-Version: 20180618.2101
;; Keywords: convenience
;; URL: https://github.com/creichert/ido-vertical-mode.el
@ -29,6 +28,7 @@
;;; Code:
(require 'ido)
(require 'cl-lib)
;;; The following three variables and their comments are lifted
;;; 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) 2012-2014 Steve Purcell <steve@sanityinc.com>
@ -36,16 +36,20 @@
(require 'package-build)
(defun package-build--write-melpa-badge-image (name version target-dir)
(shell-command
(mapconcat #'shell-quote-argument
(list "curl" "-f" "-o"
(expand-file-name (concat name "-badge.svg") target-dir)
(format "https://img.shields.io/badge/%s-%s-%s.svg"
(if package-build-stable "melpa stable" "melpa")
(url-hexify-string version)
(if package-build-stable "3e999f" "922793")))
" ")))
(unless (zerop (call-process
"curl" nil nil nil "-f" "-o"
(expand-file-name (concat name "-badge.svg") target-dir)
(format "https://img.shields.io/badge/%s-%s-%s.svg"
(if package-build-stable "melpa stable" "melpa")
(url-hexify-string version)
(if package-build-stable "3e999f" "922793"))))
(message "Failed to fetch badge")))
(provide 'package-build-badges)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End:
;;; 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) 2012-2020 Steve Purcell <steve@sanityinc.com>
;; Copyright (C) 2016-2020 Jonas Bernoulli <jonas@bernoul.li>
;; Copyright (C) 2011-2021 Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Copyright (C) 2012-2021 Steve Purcell <steve@sanityinc.com>
;; Copyright (C) 2016-2021 Jonas Bernoulli <jonas@bernoul.li>
;; Copyright (C) 2009 Phil Hagelberg <technomancy@gmail.com>
;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
;; 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.
;; However, it is distributed under the same license.
@ -39,6 +41,8 @@
;;; Code:
(require 'cl-lib)
(require 'pcase)
(require 'subr-x)
(require 'package)
(require 'lisp-mnt)
@ -198,7 +202,8 @@ is used instead."
(file-name-as-directory (or directory default-directory)))
(argv (nconc (unless (eq system-type 'windows-nt)
(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
"-k" "60" (number-to-string
package-build-timeout-secs)
@ -229,20 +234,14 @@ is used instead."
;;; Checkout
;;;; 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 "Fetcher: %s"
(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 "Fetcher: %s" (package-recipe--fetcher rcp))
(package-build--message "Source: %s\n" (package-recipe--upstream-url rcp)))
;;;; 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))
(url (package-recipe--upstream-url rcp)))
(cond
@ -271,7 +270,7 @@ is used instead."
(package-build--expand-source-file-list rcp)))
(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)))
(unless rev
(setq rev (or (oref rcp commit)
@ -287,13 +286,20 @@ is used instead."
(package-build--run-process dir nil "git" "submodule" "update"
"--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)))
(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
(defmethod package-build--checkout ((rcp package-hg-recipe))
(cl-defmethod package-build--checkout ((rcp package-hg-recipe))
(let ((dir (package-recipe--working-tree rcp))
(url (package-recipe--upstream-url rcp)))
(cond
@ -325,84 +331,122 @@ is used instead."
(package-build--expand-source-file-list rcp)))
(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-recipe--working-tree rcp)
"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)
"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))))
;;; Generate Files
(defun package-build--create-tar (file dir &optional files)
"Create a tar FILE containing the contents of DIR, or just FILES if non-nil."
(when (eq system-type 'windows-nt)
(setq file (replace-regexp-in-string "^\\([a-z]\\):" "/\\1" file)))
(apply 'process-file
package-build-tar-executable nil
(get-buffer-create "*package-build-checkout*")
nil "-cvf"
file
"--exclude=.git"
"--exclude=.hg"
(or (mapcar (lambda (fn) (concat dir "/" fn)) files) (list dir))))
(defun package-build--write-pkg-file (desc dir)
(let ((name (package-desc-name desc)))
(with-temp-file (expand-file-name (format "%s-pkg.el" name) dir)
(pp `(define-package ,(symbol-name name)
,(package-version-join (package-desc-version desc))
,(package-desc-summary desc)
',(mapcar (pcase-lambda (`(,pkg ,ver))
(list pkg (package-version-join ver)))
(package-desc-reqs desc))
,@(cl-mapcan (pcase-lambda (`(,key . ,val))
(when (or (symbolp val) (listp val))
;; 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)
"Get commentary section from FILE-PATH."
(when (file-exists-p file-path)
(defun package-build--create-tar (name version directory)
"Create a tar file containing the contents of VERSION of package NAME."
(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
(insert-file-contents file-path)
(lm-commentary))))
(defun package-build--write-pkg-readme (target-dir commentary file-name)
"In TARGET-DIR, write COMMENTARY to a -readme.txt file prefixed with FILE-NAME."
(when commentary
(with-temp-buffer
(insert commentary)
;; Adapted from `describe-package-1'.
(goto-char (point-min))
(save-excursion
(when (re-search-forward "^;;; Commentary:\n" nil t)
(replace-match ""))
(while (re-search-forward "^\\(;+ ?\\)" nil t)
(replace-match ""))
(goto-char (point-min))
(when (re-search-forward "\\`\\( *\n\\)+" nil t)
(replace-match "")))
(delete-trailing-whitespace)
(if (>= emacs-major-version 27)
(insert commentary)
;; Taken from 27.1's `lm-commentary'.
(insert
(replace-regexp-in-string ; Get rid of...
"[[:blank:]]*$" "" ; trailing white-space
(replace-regexp-in-string
(format "%s\\|%s\\|%s"
;; commentary header
(concat "^;;;[[:blank:]]*\\("
lm-commentary-header
"\\):[[:blank:]\n]*")
"^;;[[:blank:]]*" ; double semicolon prefix
"[[:blank:]\n]*\\'") ; trailing new-lines
"" commentary))))
(unless (= (char-before) ?\n)
(insert ?\n))
(let ((coding-system-for-write buffer-file-coding-system))
(write-region nil nil
(expand-file-name (concat file-name "-readme.txt")
target-dir))))))
(expand-file-name (concat name "-readme.txt")
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)
"Ensure current buffer has NAME header with the given VALUE.
@ -425,12 +469,12 @@ still be renamed."
(insert (format ";; %s: %s" name value))
(newline))
(defun package-build--ensure-ends-here-line (file-path)
"Add a 'FILE-PATH ends here' trailing line if missing."
(defun package-build--ensure-ends-here-line (file)
"Add a 'FILE ends here' trailing line if missing."
(save-excursion
(goto-char (point-min))
(let ((trailer (concat ";;; "
(file-name-nondirectory file-path)
(file-name-nondirectory file)
" ends here")))
(unless (search-forward trailer nil t)
(goto-char (point-max))
@ -438,143 +482,86 @@ still be renamed."
(insert trailer)
(newline)))))
(defun package-build--get-package-info (file-path)
"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))))))
;;; Package Structs
(defun package-build--package-buffer-info-vec ()
"Return a vector of package info.
`package-buffer-info' returns a vector in older Emacs versions,
and a cl struct in Emacs HEAD. This wrapper normalises the results."
(let ((desc (package-buffer-info))
(keywords (lm-keywords-list)))
(if (fboundp 'package-desc-create)
(let ((extras (package-desc-extras desc)))
(when (and keywords (not (assq :keywords extras)))
(push (cons :keywords keywords) extras))
(vector (package-desc-name desc)
(package-desc-reqs desc)
(package-desc-summary desc)
(package-desc-version desc)
extras))
(let ((homepage (package-build--lm-homepage))
extras)
(when keywords (push (cons :keywords keywords) extras))
(when homepage (push (cons :url homepage) extras))
(vector (aref desc 0)
(aref desc 1)
(aref desc 2)
(aref desc 3)
extras)))))
(defun package-build--desc-from-library (name version commit files &optional type)
(let* ((file (concat name ".el"))
(file (or (car (rassoc file files)) file)))
(and (file-exists-p file)
(with-temp-buffer
(insert-file-contents file)
(package-desc-from-define
name version
(or (save-excursion
(goto-char (point-min))
(and (re-search-forward
"^;;; [^ ]*\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"
nil t)
(match-string-no-properties 1)))
"No description available.")
(when-let ((require-lines (lm-header-multiline "package-requires")))
(package--prepare-dependencies
(package-read-from-string (mapconcat #'identity require-lines " "))))
:kind (or type 'single)
:url (lm-homepage)
:keywords (lm-keywords-list)
:maintainer (lm-maintainer)
:authors (lm-authors)
:commit commit)))))
(defun package-build--get-pkg-file-info (file-path)
"Get a vector of package info from \"-pkg.el\" file FILE-PATH."
(when (file-exists-p file-path)
(let ((package-def (with-temp-buffer
(insert-file-contents file-path)
(read (current-buffer)))))
(if (eq 'define-package (car package-def))
(let* ((pkgfile-info (cdr package-def))
(descr (nth 2 pkgfile-info))
(rest-plist (cl-subseq pkgfile-info (min 4 (length pkgfile-info))))
(extras (let (alist)
(while rest-plist
(unless (memq (car rest-plist) '(:kind :archive))
(let ((value (cadr rest-plist)))
(when value
(push (cons (car rest-plist)
(if (eq (car-safe value) 'quote)
(cadr value)
value))
alist))))
(setq rest-plist (cddr rest-plist)))
alist)))
(when (string-match "[\r\n]" descr)
(error "Illegal multi-line package description in %s" file-path))
(vector
(nth 0 pkgfile-info)
(mapcar
(lambda (elt)
(unless (symbolp (car elt))
(error "Invalid package name in dependency: %S" (car elt)))
(list (car elt) (version-to-list (cadr elt))))
(eval (nth 3 pkgfile-info)))
descr
(nth 1 pkgfile-info)
extras))
(error "No define-package found in %s" file-path)))))
(defun package-build--desc-from-package (name version commit files)
(let* ((file (concat name "-pkg.el"))
(file (or (car (rassoc file files))
file)))
(and (or (file-exists-p file)
(file-exists-p (setq file (concat file ".in"))))
(let ((form (with-temp-buffer
(insert-file-contents file)
(read (current-buffer)))))
(unless (eq (car form) 'define-package)
(error "No define-package found in %s" file))
(pcase-let*
((`(,_ ,_ ,_ ,summary ,deps . ,extra) form)
(deps (eval deps))
(alt-desc (package-build--desc-from-library
name version nil files))
(alt (and alt-desc (package-desc-extras alt-desc))))
(when (string-match "[\r\n]" summary)
(error "Illegal multi-line package description in %s" file))
(package-desc-from-define
name version
(if (string-empty-p summary)
(or (and alt-desc (package-desc-summary alt-desc))
"No description available.")
summary)
(mapcar (pcase-lambda (`(,pkg ,ver))
(unless (symbolp pkg)
(error "Invalid package name in dependency: %S" pkg))
(list pkg ver))
deps)
:kind 'tar
:url (or (alist-get :url extra)
(alist-get :homepage extra)
(alist-get :url alt))
:keywords (or (alist-get :keywords extra)
(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)
"Return a version of PKG-INFO updated with NAME, VERSION and info from CONFIG.
If PKG-INFO is nil, an empty one is created."
(let ((merged (or (copy-sequence pkg-info)
(vector name nil "No description available." version nil))))
(aset merged 0 name)
(aset merged 3 version)
(when commit
(aset merged 4 (cons (cons :commit commit) (elt pkg-info 4))))
merged))
(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)))
(defun package-build--write-archive-entry (desc)
(with-temp-file
(expand-file-name (concat (package-desc-full-name desc) ".entry")
package-build-archive-dir)
(pp (cons (package-desc-name desc)
(vector (package-desc-version desc)
(package-desc-reqs desc)
(package-desc-summary desc)
(package-desc-kind desc)
(package-desc-extras desc)))
(current-buffer))))
;;; File Specs
@ -595,7 +582,7 @@ for ALLOW-EMPTY to prevent this error."
(let ((default-directory dir)
(prefix (if subdir (format "%s/" subdir) ""))
(lst))
(dolist (entry specs lst)
(dolist (entry specs)
(setq lst
(if (consp entry)
(if (eq :exclude (car entry))
@ -612,7 +599,6 @@ for ALLOW-EMPTY to prevent this error."
t)))
(nconc
lst (mapcar (lambda (f)
(let ((destname)))
(cons f
(concat prefix
(replace-regexp-in-string
@ -640,65 +626,15 @@ for ALLOW-EMPTY to prevent this error."
(package-recipe--working-tree 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)
"Copy FILES from SOURCE-DIR to TARGET-DIR.
FILES is a list of (SOURCE . DEST) relative filepath pairs."
(package-build--message
"Copying files (->) and directories (=>)\n from %s\n to %s"
source-dir target-dir)
(dolist (elt files)
(let* ((src (car elt))
(dst (cdr elt))
(src* (expand-file-name src source-dir))
(dst* (expand-file-name dst target-dir)))
(pcase-dolist (`(,src . ,dst) files)
(let ((src* (expand-file-name src source-dir))
(dst* (expand-file-name dst target-dir)))
(make-directory (file-name-directory dst*) t)
(cond ((file-regular-p src*)
(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)
(copy-directory src* dst*))))))
(defconst package-build--this-file load-file-name)
;;; Building
;;; Commands
;;;###autoload
(defun package-build-archive (name &optional dump-archive-contents)
"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."
(interactive (list (package-recipe-read-name) t))
(let ((start-time (current-time))
@ -733,8 +667,7 @@ are subsequently dumped."
(package-build--message "Built %s in %.3fs, finished at %s"
name
(float-time (time-since start-time))
(current-time-string))
(list name version)))
(current-time-string))))
(when 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))
((= 1 (length files))
(package-build--build-single-file-package
rcp version commit (caar files) source-dir))
rcp version commit files source-dir))
((< 1 (length files))
(package-build--build-multi-file-package
rcp version commit files source-dir))
(t (error "Unable to find files matching recipe patterns")))))
(define-obsolete-function-alias 'package-build-package 'package-build--package
"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)
(defun package-build--build-single-file-package (rcp version commit files source-dir)
(let* ((name (oref rcp name))
(pkg-source (expand-file-name file source-dir))
(pkg-target (expand-file-name
(concat name "-" version ".el")
package-build-archive-dir))
(pkg-info (package-build--merge-package-info
(package-build--get-package-info pkg-source)
name version commit)))
(file (caar files))
(source (expand-file-name file source-dir))
(target (expand-file-name (concat name "-" version ".el")
package-build-archive-dir))
(desc (let ((default-directory source-dir))
(package-build--desc-from-library
name version commit files))))
(unless (string-equal (downcase (concat name ".el"))
(downcase (file-name-nondirectory pkg-source)))
(error "Single file %s does not match package name %s"
(file-name-nondirectory pkg-source) name))
(copy-file pkg-source pkg-target t)
(downcase file))
(error "Single file %s does not match package name %s" file name))
(copy-file source target t)
(let ((enable-local-variables 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-Version" version)
(package-build--ensure-ends-here-line pkg-source)
(write-file pkg-target nil)
(condition-case err
(package-build--package-buffer-info-vec)
(error
(package-build--message "Warning: %S" err)))
(package-build--ensure-ends-here-line source)
(write-file target nil)
(kill-buffer)))
(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 'single)))
(package-build--write-pkg-readme name files source-dir)
(package-build--write-archive-entry desc)))
(defun package-build--build-multi-file-package (rcp version commit files source-dir)
(let* ((name (oref rcp name))
(tmp-dir (file-name-as-directory (make-temp-file name t))))
(unwind-protect
(let* ((pkg-dir-name (concat name "-" version))
(pkg-tmp-dir (expand-file-name pkg-dir-name tmp-dir))
(pkg-file (concat name "-pkg.el"))
(pkg-file-source (or (car (rassoc pkg-file files))
pkg-file))
(file-source (concat name ".el"))
(pkg-source (or (car (rassoc file-source files))
file-source))
(pkg-info (package-build--merge-package-info
(let ((default-directory source-dir))
(or (package-build--get-pkg-file-info pkg-file-source)
;; Some packages provide NAME-pkg.el.in
(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))
(let* ((target (expand-file-name (concat name "-" version) tmp-dir))
(desc (let ((default-directory source-dir))
(or (package-build--desc-from-package
name version commit files)
(package-build--desc-from-library
name version commit files 'tar)))))
(package-build--copy-package-files files source-dir target)
(package-build--write-pkg-file desc target)
(package-build--generate-info-files files source-dir target)
(package-build--create-tar name version tmp-dir)
(package-build--write-pkg-readme name files source-dir)
(package-build--write-archive-entry desc))
(delete-directory tmp-dir t nil))))
;;;###autoload
@ -899,27 +787,31 @@ Do not use this alias elsewhere.")
If non-nil, then store the archive contents in FILE instead of in
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."
(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
(insert-file-contents file)
(read (current-buffer))))
(name (car entry))
(other-entry (assq name entries)))
(newer-entry (assq name entries)))
(if (not (file-exists-p (expand-file-name (symbol-name name)
package-build-recipes-dir)))
(package-build--remove-archive-files entry)
(when other-entry
(when (version-list-< (elt (cdr entry) 0)
(elt (cdr other-entry) 0))
;; Swap so that other-entry has the smallest version.
(cl-rotatef other-entry entry))
(package-build--remove-archive-files other-entry)
(setq entries (remove other-entry entries)))
(add-to-list 'entries entry))))
(setq entries (nreverse entries))
;; Prefer the more-recently-built package, which may not
;; necessarily have the highest version number, e.g. if
;; commit histories were changed.
(if newer-entry
(package-build--remove-archive-files entry)
(push entry entries)))))
(setq entries (sort entries (lambda (a b)
(string< (symbol-name (car a))
(symbol-name (car b))))))
(with-temp-file
(or file
(expand-file-name "archive-contents" package-build-archive-dir))
@ -935,8 +827,6 @@ line per entry."
(insert ")"))))
entries))
(defalias 'package-build--archive-entries 'package-build-dump-archive-contents)
(defun package-build--remove-archive-files (archive-entry)
"Remove the entry and archive file for ARCHIVE-ENTRY."
(package-build--message "Removing archive: %s-%s"
@ -949,11 +839,28 @@ line per entry."
(when (file-exists-p 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)
"Dump the recipe list to FILE as json."
(interactive)
(interactive "FDump json to file: ")
(with-temp-file file
(insert
(json-encode
@ -973,12 +880,7 @@ line per entry."
(defun package-build--pkg-info-for-json (info)
"Convert INFO into a data structure which will serialize to JSON in the desired shape."
(let ((ver (elt info 0))
(deps (elt info 1))
(desc (elt info 2))
(type (elt info 3))
(props (and (> (length info) 4)
(elt info 4))))
(pcase-let ((`(,ver ,deps ,desc ,type . (,props)) (append info nil)))
(list :ver ver
:deps (cl-mapcan (lambda (dep)
(list (intern (format ":%s" (car dep)))
@ -1020,19 +922,11 @@ line per entry."
(with-temp-file file
(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)
;; 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-recipe-mode)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End:
;;; 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) 2012-2014 Steve Purcell <steve@sanityinc.com>
;; Copyright (C) 2011-2020 Donald Ephraim Curtis <dcurtis@milkbox.net>
;; 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>
;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
@ -55,8 +56,7 @@
(interactive
(list (read-string "Package name: ")
(intern (completing-read "Fetcher: "
(list "git" "github" "gitlab"
"hg" "bitbucket")
(list "git" "github" "gitlab" "hg")
nil t nil nil "github"))))
(let ((recipe-file (expand-file-name name package-build-recipes-dir)))
(when (file-exists-p recipe-file)
@ -101,5 +101,10 @@
(assq (intern name) (package-build-archive-alist)))))))
(provide 'package-recipe-mode)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End:
;;; 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 -*-
;; Copyright (C) 2018 Jonas Bernoulli
;; Copyright (C) 2018-2020 Jonas Bernoulli
;; Author: Jonas Bernoulli <jonas@bernoul.li>
@ -51,15 +51,18 @@
(old-names :initarg :old-names :initform nil))
:abstract t)
(defmethod package-recipe--working-tree ((rcp package-recipe))
(cl-defmethod package-recipe--working-tree ((rcp package-recipe))
(file-name-as-directory
(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)
(format (oref rcp url-format)
(oref rcp repo))))
(cl-defmethod package-recipe--fetcher ((rcp package-recipe))
(substring (symbol-name (eieio-object-class rcp)) 8 -7))
;;;; Git
(defclass package-git-recipe (package-recipe)
@ -82,10 +85,6 @@
\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} \
[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
(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)))
(let ((fetcher (plist-get plist :fetcher)))
(cl-assert fetcher nil ":fetcher is missing")
(if (memq fetcher '(github gitlab bitbucket))
(if (memq fetcher '(github gitlab))
(progn
(cl-assert (plist-get plist :repo) ":repo is missing")
(cl-assert (not (plist-get plist :url)) ":url is redundant"))
@ -159,5 +158,9 @@ file is invalid, then raise an error."
;;; _
(provide 'package-recipe)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: 1
;; indent-tabs-mode: nil
;; End:
;;; 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
@ -105,9 +105,6 @@ horizontal line of `page-break-lines-char' characters."
:group 'page-break-lines
(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
window-size-change-functions
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)
(let* ((cwidth (char-width page-break-lines-char))
(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)
0)))
(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)
;; Local Variables:
;; coding: utf-8
;; checkdoc-minor-mode: t
;; End:
;;; 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>
;; Author: steckerhalter
;; URL: https://framagit.org/steckerhalter/quelpa
;; Version: 0.0.1
;; Package-Requires: ((emacs "24.3"))
;; Keywords: package management build source elpa
;; URL: https://github.com/quelpa/quelpa
;; Version: 1.0
;; Package-Requires: ((emacs "25.1"))
;; Keywords: tools package management build source elpa
;; This file is not part of GNU Emacs.
@ -32,11 +32,11 @@
;; built on-the-fly directly from source.
;; 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:
;; Emacs 24.3.1
;; Emacs 25.1
;;; Code:
@ -45,6 +45,7 @@
(require 'url-parse)
(require 'package)
(require 'lisp-mnt)
(eval-when-compile (require 'subr-x))
;; --- customs / variables ---------------------------------------------------
@ -64,6 +65,13 @@ the `:upgrade' argument."
:group 'quelpa
: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
"When non-nil, `quelpa' prints log messages."
:group 'quelpa
@ -153,46 +161,20 @@ quelpa cache."
:type '(choice (const :tag "Don't shallow clone" nil)
(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
"Non-nil when quelpa has been initialized.")
(defvar quelpa-cache nil
"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.")
;; --- 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 ------------------------------------------------------
(defun quelpa-package-type (file)
@ -217,14 +199,9 @@ On error return nil."
(`tar (insert-file-contents-literally file)
(tar-mode)
(with-no-warnings
(if (help-function-arglist 'package-tar-file-info)
;; legacy `package-tar-file-info' requires an arg
(package-tar-file-info file)
(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))))))
(package-tar-file-info))))))))
(when (package-desc-p desc)
desc)))
(defun quelpa-archive-file-name (archive-entry)
"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"))
quelpa-packages-dir)))
(defun quelpa-version>-p (name version)
"Return non-nil if VERSION of pkg with NAME is newer than what is currently installed."
(not (or (not version)
(let ((pkg-desc (cdr (assq name package-alist))))
(and pkg-desc
(version-list-<=
(version-to-list version)
(package-desc-version (car pkg-desc)))))
;; Also check built-in packages.
(package-built-in-p name (version-to-list version)))))
(defconst quelpa--min-ver '(0 -10) "Smallest possible version.")
(defun quelpa-version-cmp (name version op)
"Return non-nil if version of pkg with NAME and VERSION satisfies OP.
OP is taking two version list and comparing."
(let ((ver (if version (version-to-list version) quelpa--min-ver))
(pkg-ver
(or (when-let ((pkg-desc (cdr (assq name package-alist)))
(pkg-ver (package-desc-version (car pkg-desc))))
pkg-ver)
(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)
"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."
(pcase-let ((`(,name . ,config) rcp)
(quelpa-build-stable quelpa-stable-p))
(unless (or (and (assq name package-alist) (not quelpa-upgrade-p))
(quelpa-build-stable quelpa-stable-p)
(quelpa--override-version-check quelpa--override-version-check))
(unless (or (and (quelpa--package-installed-p name) (not quelpa-upgrade-p))
(and (not config)
(quelpa-message t "no recipe found for package `%s'" name)))
(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 "Failed to checkout `%s': `%s'"
name (error-message-string err))))))
(when (quelpa-version>-p name version)
version)))))
(cond
((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)
"Build a package from the given recipe RCP.
@ -273,13 +279,18 @@ already and should not be upgraded etc)."
(let* ((name (car rcp))
(build-dir (expand-file-name (symbol-name name) quelpa-build-dir))
(version (quelpa-checkout rcp build-dir)))
(when version
(quelpa-archive-file-name
(quelpa-build-package (symbol-name name)
version
(quelpa-build--config-file-list (cdr rcp))
build-dir
quelpa-packages-dir)))))
(prog1
(if version
(quelpa-archive-file-name
(quelpa-build-package (symbol-name name)
version
(quelpa-build--config-file-list (cdr rcp))
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 ------------------------------------------
@ -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))
(remote (or (plist-get config :remote) "origin"))
(commit (or (plist-get config :commit)
(let ((branch (plist-get config :branch)))
(when branch (concat remote "/" branch)))))
(when-let ((branch (plist-get config :branch)))
(concat remote "/" branch))))
(depth (or (plist-get config :depth) quelpa-git-clone-depth))
(force (plist-get config :force))
(use-current-ref (plist-get config :use-current-ref)))
(when (string-match (rx bos "file://" (group (1+ anything))) repo)
;; Expand local file:// URLs
(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*")
(goto-char (point-max))
(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)))
`("--depth" ,(int-to-string depth)
"--no-single-branch"))
(let ((branch (plist-get config :branch)))
(when branch `("--branch" ,branch)))))))
(when-let ((branch (plist-get config :branch)))
`("--branch" ,branch))))))
(if quelpa-build-stable
(let* ((min-bound (goto-char (point-max)))
(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))))
(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)
"Check package NAME with config CONFIG out of gitlab into DIR."
(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)
(while rest-plist
(unless (memq (car rest-plist) '(:kind :archive))
(let ((value (cadr rest-plist)))
(when value
(push (cons (car rest-plist)
(if (eq (car-safe value) 'quote)
(cadr value)
value))
alist))))
(when-let ((value (cadr rest-plist)))
(push (cons (car rest-plist)
(if (eq (car-safe value) 'quote)
(cadr value)
value))
alist)))
(setq rest-plist (cddr rest-plist)))
alist)))
(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-version desc)
extras))
;; The regexp and the processing is taken from `lm-homepage' in Emacs 24.4
(let* ((page (lm-header "\\(?:x-\\)?\\(?:homepage\\|url\\)"))
(homepage (if (and page (string-match "^<.+>$" page))
(substring page 1 -1)
page))
extras)
(let ((homepage (lm-homepage))
extras)
(when keywords (push (cons :keywords keywords) extras))
(when homepage (push (cons :url homepage) extras))
(vector (aref desc 0)
@ -1671,15 +1683,22 @@ Return t in each case."
;; default value anyways
(when (plist-member (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))))
(defun quelpa-checkout-melpa ()
;;;###autoload
(defun quelpa-checkout-melpa (&optional force)
"Fetch or update the melpa source code from Github.
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 and no existing checkout return nil."
(or (and (null quelpa-update-melpa-p)
If there is an error and no existing checkout return nil.
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)))
(condition-case err
(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."
(cl-loop for store in quelpa-melpa-recipe-stores
if (stringp store)
for file = (assoc-string name (directory-files store nil "^[^\.]+"))
for file = (assoc-string name (directory-files store nil "^[^.].*$"))
when file
return (with-temp-buffer
(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 quelpa-initialized-p
(quelpa-read-cache)
(quelpa-setup-package-structs)
(if quelpa-checkout-melpa-p
(unless (quelpa-checkout-melpa) (throw 'quit nil)))
(when (and quelpa-checkout-melpa-p
(not (quelpa-checkout-melpa)))
(throw 'quit nil))
(unless package-alist (package-load-all-descriptors))
(setq quelpa-initialized-p 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).
If RCP cannot be found it will be set to nil"
(pcase arg
(`(,a . nil) (quelpa-get-melpa-recipe (car arg)))
(`(,a . ,_) arg)
((pred symbolp) (quelpa-get-melpa-recipe arg))))
(`(,name) (quelpa-get-melpa-recipe name))
(`(,name . ,_) arg)
(name (quelpa-get-melpa-recipe name))))
(defun quelpa-parse-plist (plist)
"Parse the optional PLIST argument of `quelpa'.
@ -1742,13 +1762,18 @@ If t, `quelpa' tries to do an upgrade.
: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
(let ((key (car plist))
(value (cadr plist)))
(pcase key
(: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))))
(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)
"Build and install package from ARG (a recipe or package name).
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))
(file (when rcp (quelpa-build (append rcp plist)))))
(when 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
(mapc (lambda (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))))
requires))
(quelpa-package-install-file file)))))
(quelpa-package-install-file file)
ver))))
(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)
(let ((recipes (cl-loop
for store in quelpa-melpa-recipe-stores
if (stringp store)
;; this regexp matches all files except dotfiles
append (directory-files store nil "^[^.].+$")
else if (listp store)
append store)))
(intern (completing-read "Choose MELPA recipe: "
recipes nil t)))))
(let* ((recipes (cl-loop
for store in quelpa-melpa-recipe-stores
if (stringp store)
;; this regexp matches all files except dotfiles
append (directory-files store nil "^[^.].*$")
else if (listp store)
append store))
(recipe (completing-read "Choose MELPA recipe: " 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 ------------------------------------------------------
;;;###autoload
(defun quelpa-expand-recipe (recipe-name)
"Expand a given RECIPE-NAME into full recipe.
(defun quelpa-expand-recipe (recipe)
"Expand a given RECIPE into full recipe.
If called interactively, let the user choose a recipe name and
insert the result into the current buffer."
(interactive (list (quelpa-interactive-candidate)))
(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
(if (called-interactively-p 'any)
(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."
(interactive "P")
(when (quelpa-setup-p)
(let ((quelpa-upgrade-p t))
(when quelpa-self-upgrade-p
(quelpa-self-upgrade))
(setq quelpa-cache
(cl-remove-if-not #'package-installed-p quelpa-cache :key #'car))
(mapc (lambda (item)
(when (package-installed-p (car (quelpa-arg-rcp item)))
(quelpa item :force force)))
quelpa-cache))))
(when quelpa-self-upgrade-p
(quelpa-self-upgrade))
(mapc (lambda (rcp)
(quelpa-upgrade rcp (when force 'force)))
quelpa-cache)))
;;;###autoload
(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])
for upgrade using current working tree."
(interactive
(when (quelpa-setup-p)
(let* ((quelpa-melpa-recipe-stores (list quelpa-cache))
(name (quelpa-interactive-candidate))
(prefix (prefix-numeric-value current-prefix-arg)))
(list (assoc name quelpa-cache)
(cond ((eq prefix 4) 'force)
((eq prefix 16) 'local))))))
(when rcp
(let ((quelpa-upgrade-p t)
(current-prefix-arg nil)
(config (cond ((eq action 'force) `(:force t))
((eq action 'local) `(:use-current-ref t)))))
(setq quelpa-cache
(cl-remove-if-not #'package-installed-p quelpa-cache :key #'car))
(when (package-installed-p (car (quelpa-arg-rcp rcp)))
(let ((prefix (prefix-numeric-value current-prefix-arg)))
(list nil
(cond ((eq prefix 4) 'force)
((eq prefix 16) 'local)))))
(when (quelpa-setup-p)
(let* ((rcp (or rcp
(let ((quelpa-melpa-recipe-stores
(list (cl-remove-if-not #'quelpa--package-installed-p
quelpa-cache :key #'car))))
(quelpa-interactive-candidate))))
(quelpa-upgrade-p t)
(current-prefix-arg nil)
(config (append (cond ((eq action 'force) `(:force t))
((eq action 'local) `(:use-current-ref t)))
`(:autoremove ,quelpa-autoremove-p))))
(when (quelpa--package-installed-p (car (quelpa-arg-rcp rcp)))
(apply #'quelpa rcp config)))))
;;;###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
given package even if the global var `quelpa-upgrade-p' is set to
nil."
(interactive (list (quelpa-interactive-candidate)))
(interactive (list nil))
(run-hooks 'quelpa-before-hook)
(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'
(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-stable cache-item)
(apply #'quelpa-package-install arg plist)
(quelpa-update-cache cache-item)))
(when-let ((ver (apply #'quelpa-package-install arg plist)))
(when quelpa-autoremove-p
(quelpa--delete-obsoleted-package (car cache-item) ver))
(quelpa-update-cache cache-item))))
(quelpa-shutdown)
(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)
;;; 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")))
(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")))
(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")))
(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")))
@ -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))))
`(vertical-border ((,class (:foreground ,border))))
`(warning ((,class (:foreground ,war))))
`(widget-button-pressed ((,class (:foreground ,green))))
;;;;; ace-window
`(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-unselected ((,class (:background ,bg2 :foreground ,base-dim :weight light))))
`(centaur-tabs-selected-modified ((,class (:background ,bg1
:foreground ,blue :weight bold))))
:foreground ,blue :weight bold))))
`(centaur-tabs-unselected-modified ((,class (:background ,bg2 :weight light
:foreground ,blue))))
:foreground ,blue))))
`(centaur-tabs-active-bar-face ((,class (:background ,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))))
@ -280,7 +282,7 @@ to 'auto, tags may not be properly aligned. "
`(company-tooltip ((,class (:background ,ttip-bg :foreground ,ttip))))
`(company-tooltip-annotation ((,class (:foreground ,type))))
`(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-search ((,class (:inherit match))))
`(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-hl
`(diff-hl-change ((,class :background ,blue-bg-s :foreground ,blue)))
`(diff-hl-delete ((,class :background ,red-bg-s :foreground ,red)))
`(diff-hl-insert ((,class :background ,green-bg-s :foreground ,green)))
`(diff-hl-insert ((,class :background ,green :foreground ,green)))
`(diff-hl-delete ((,class :background ,red :foreground ,red)))
`(diff-hl-change ((,class :background ,blue :foreground ,blue)))
;;;;; dired
`(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:added ((,class (:foreground ,green :inherit bold))))
`(git-gutter-fr:deleted ((,class (:foreground ,war :inherit bold))))
`(git-gutter-fr:modified ((,class (:foreground ,keyword :inherit bold))))
`(git-gutter-fr:deleted ((,class (:foreground ,red :inherit bold))))
`(git-gutter-fr:modified ((,class (:foreground ,blue :inherit bold))))
;;;;; git-timemachine
`(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-symbol
`(highlight-symbol-face ((,class (:background ,bg2))))
`(highlight-symbol-face ((,class (:background ,bg-alt))))
;;;;; highlight-thing
`(highlight-thing ((,class (:background ,bg-alt))))
;;;;; hydra
`(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-4 ((,class (:foreground ,head3 :underline t))))
`(ivy-remote ((,class (:foreground ,cyan))))
;;;;; ivy-posframe
`(ivy-posframe ((,class (:background ,bg3))))
@ -618,6 +623,12 @@ to 'auto, tags may not be properly aligned. "
;;;;; linum-relative
`(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-blame-culprit ((,class :background ,yellow-bg :foreground ,yellow)))
`(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-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
`(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-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-builtin-face ((,class (:inherit ,font-lock-builtin-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
`spinner-types' variable, but you can also use your own (see
below).
If TYPE is nil, the frames of this spinner are given by the first
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)
"Create a spinner of the given TYPE.
The possible TYPEs are described in `spinner--type-to-frames'.
FPS, if given, is the number of desired frames per second.
Default is `spinner-frames-per-second'.
If BUFFER-LOCAL is non-nil, the spinner will be automatically
deactivated if the buffer is killed. If BUFFER-LOCAL is a
buffer, use that instead of current buffer.
When started, in order to function properly, the spinner runs a
timer which periodically calls `force-mode-line-update' in the
curent buffer. If BUFFER-LOCAL was set at creation time, then
`force-mode-line-update' is called in that buffer instead. When
the spinner is stopped, the timer is deactivated.
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 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:
'(:eval (spinner-print THE-SPINNER))
To stop this spinner, call `spinner-stop' on it.
If TYPE-OR-OBJECT is anything else, a buffer-local spinner is
created with this type, and it is displayed in the
`mode-line-process' of the buffer it was created it. Both
TYPE-OR-OBJECT and FPS are passed to `make-spinner' (which see).
To stop this spinner, call `spinner-stop' in the same buffer.
Either way, the return value is a function which can be called
anywhere to stop this spinner. You can also call `spinner-stop'
in the same buffer where the spinner was created.
FPS, if given, is the number of desired frames per second.
Default is `spinner-frames-per-second'.
DELAY, if given, is the number of seconds to wait until actually
displaying the spinner. It is safe to cancel the spinner before
this time, in which case it won't display at all."