From 01f8ccbefb9dd40c1a3366707cd17df5617bee2a Mon Sep 17 00:00:00 2001 From: emacspace Date: Sun, 10 Jan 2021 20:14:15 +0000 Subject: [PATCH] Built-in files auto-update: Sun Jan 10 20:14:15 UTC 2021 --- core/libs/dash.el | 1329 +++++++++-------- core/libs/ht.el | 105 +- core/libs/ido-vertical-mode.el | 2 +- core/libs/package-build-badges.el | 24 +- core/libs/package-build.el | 679 ++++----- core/libs/package-recipe-mode.el | 15 +- core/libs/package-recipe.el | 19 +- core/libs/page-break-lines.el | 13 +- core/libs/quelpa.el | 354 +++-- core/libs/spacemacs-theme/spacemacs-common.el | 43 +- core/libs/spinner.el | 9 + 11 files changed, 1343 insertions(+), 1249 deletions(-) diff --git a/core/libs/dash.el b/core/libs/dash.el index bc713ce2f..a60b10711 100644 --- a/core/libs/dash.el +++ b/core/libs/dash.el @@ -1,12 +1,14 @@ ;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*- -;; Copyright (C) 2012-2016 Free Software Foundation, Inc. +;; Copyright (C) 2012-2021 Free Software Foundation, Inc. ;; Author: Magnar Sveen ;; Version: 2.17.0 -;; Keywords: lists +;; Package-Requires: ((emacs "24")) +;; Keywords: extensions, lisp +;; Homepage: https://github.com/magnars/dash.el -;; This program is free software; you can redistribute it and/or modify +;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. @@ -17,19 +19,13 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . +;; along with this program. If not, see . ;;; Commentary: -;; A modern list api for Emacs. -;; -;; See documentation on https://github.com/magnars/dash.el#functions -;; -;; **Please note** The lexical binding in this file is not utilised at the -;; moment. We will take full advantage of lexical binding in an upcoming 3.0 -;; release of Dash. In the meantime, we've added the pragma to avoid a bug that -;; you can read more about in https://github.com/magnars/dash.el/issues/130. +;; A modern list API for Emacs. ;; +;; See its overview at https://github.com/magnars/dash.el#functions. ;;; Code: @@ -40,22 +36,11 @@ (require 'cl))) (defgroup dash () - "Customize group for dash.el" + "Customize group for Dash, a modern list library." + :group 'extensions :group 'lisp :prefix "dash-") -(defun dash--enable-fontlock (symbol value) - (when value - (dash-enable-font-lock)) - (set-default symbol value)) - -(defcustom dash-enable-fontlock nil - "If non-nil, enable fontification of dash functions, macros and -special values." - :type 'boolean - :set 'dash--enable-fontlock - :group 'dash) - (defmacro !cons (car cdr) "Destructive: Set CDR to the cons of CAR and CDR." `(setq ,cdr (cons ,car ,cdr))) @@ -65,265 +50,377 @@ special values." `(setq ,list (cdr ,list))) (defmacro --each (list &rest body) - "Anaphoric form of `-each'." - (declare (debug (form body)) - (indent 1)) - (let ((l (make-symbol "list"))) + "Evaluate BODY for each element of LIST and return nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating BODY. +This is the anaphoric counterpart to `-each'." + (declare (debug (form body)) (indent 1)) + (let ((l (make-symbol "list")) + (i (make-symbol "i"))) `(let ((,l ,list) - (it-index 0)) + (,i 0) + it it-index) + (ignore it it-index) (while ,l - (let ((it (car ,l))) - ,@body) - (setq it-index (1+ it-index)) - (!cdr ,l))))) - -(defmacro -doto (eval-initial-value &rest forms) - "Eval a form, then insert that form as the 2nd argument to other forms. -The EVAL-INITIAL-VALUE form is evaluated once. Its result is -passed to FORMS, which are then evaluated sequentially. Returns -the target form." - (declare (indent 1)) - (let ((retval (make-symbol "value"))) - `(let ((,retval ,eval-initial-value)) - ,@(mapcar (lambda (form) - (if (sequencep form) - `(,(-first-item form) ,retval ,@(cdr form)) - `(funcall form ,retval))) - forms) - ,retval))) - -(defmacro --doto (eval-initial-value &rest forms) - "Anaphoric form of `-doto'. -Note: `it' is not required in each form." - (declare (indent 1)) - `(let ((it ,eval-initial-value)) - ,@forms - it)) + (setq it (pop ,l) it-index ,i ,i (1+ ,i)) + ,@body)))) (defun -each (list fn) - "Call FN with every item in LIST. Return nil, used for side-effects only." - (--each list (funcall fn it))) - -(put '-each 'lisp-indent-function 1) + "Call FN on each element of LIST. +Return nil; this function is intended for side effects. +Its anaphoric counterpart is `--each'. For access to the current +element's index in LIST, see `-each-indexed'." + (declare (indent 1)) + (ignore (mapc fn list))) (defalias '--each-indexed '--each) (defun -each-indexed (list fn) - "Call (FN index item) for each item in LIST. - -In the anaphoric form `--each-indexed', the index is exposed as symbol `it-index'. - + "Call FN on each index and element of LIST. +For each ITEM at INDEX in LIST, call (funcall FN INDEX ITEM). +Return nil; this function is intended for side effects. See also: `-map-indexed'." + (declare (indent 1)) (--each list (funcall fn it-index it))) -(put '-each-indexed 'lisp-indent-function 1) (defmacro --each-while (list pred &rest body) - "Anaphoric form of `-each-while'." - (declare (debug (form form body)) - (indent 2)) + "Evaluate BODY for each item in LIST, while PRED evaluates to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating PRED or BODY. Once +an element is reached for which PRED evaluates to nil, no further +BODY is evaluated. The return value is always nil. +This is the anaphoric counterpart to `-each-while'." + (declare (debug (form form body)) (indent 2)) (let ((l (make-symbol "list")) - (c (make-symbol "continue"))) + (i (make-symbol "i")) + (elt (make-symbol "elt"))) `(let ((,l ,list) - (,c t) - (it-index 0)) - (while (and ,l ,c) - (let ((it (car ,l))) - (if (not ,pred) (setq ,c nil) ,@body)) - (setq it-index (1+ it-index)) - (!cdr ,l))))) + (,i 0) + ,elt it it-index) + (ignore it it-index) + (while (and ,l (setq ,elt (pop ,l) it ,elt it-index ,i) ,pred) + (setq it ,elt it-index ,i ,i (1+ ,i)) + ,@body)))) (defun -each-while (list pred fn) - "Call FN with every item in LIST while (PRED item) is non-nil. -Return nil, used for side-effects only." + "Call FN on each ITEM in LIST, while (PRED ITEM) is non-nil. +Once an ITEM is reached for which PRED returns nil, FN is no +longer called. Return nil; this function is intended for side +effects. +Its anaphoric counterpart is `--each-while'." + (declare (indent 2)) (--each-while list (funcall pred it) (funcall fn it))) -(put '-each-while 'lisp-indent-function 2) - (defmacro --each-r (list &rest body) - "Anaphoric form of `-each-r'." - (declare (debug (form body)) - (indent 1)) - (let ((v (make-symbol "vector"))) - ;; Implementation note: building vector is considerably faster + "Evaluate BODY for each element of LIST in reversed order. +Each element of LIST in turn, starting at its end, is bound to +`it' and its index within LIST to `it-index' before evaluating +BODY. The return value is always nil. +This is the anaphoric counterpart to `-each-r'." + (declare (debug (form body)) (indent 1)) + (let ((v (make-symbol "vector")) + (i (make-symbol "i"))) + ;; Implementation note: building a vector is considerably faster ;; than building a reversed list (vector takes less memory, so - ;; there is less GC), plus length comes naturally. In-place - ;; 'nreverse' would be faster still, but BODY would be able to see - ;; that, even if modification was reversed before we return. + ;; there is less GC), plus `length' comes naturally. In-place + ;; `nreverse' would be faster still, but BODY would be able to see + ;; that, even if the modification was undone before we return. `(let* ((,v (vconcat ,list)) - (it-index (length ,v)) - it) - (while (> it-index 0) - (setq it-index (1- it-index)) - (setq it (aref ,v it-index)) + (,i (length ,v)) + it it-index) + (ignore it it-index) + (while (> ,i 0) + (setq ,i (1- ,i) it-index ,i it (aref ,v ,i)) ,@body)))) (defun -each-r (list fn) - "Call FN with every item in LIST in reversed order. - Return nil, used for side-effects only." + "Call FN on each element of LIST in reversed order. +Return nil; this function is intended for side effects. +Its anaphoric counterpart is `--each-r'." (--each-r list (funcall fn it))) (defmacro --each-r-while (list pred &rest body) - "Anaphoric form of `-each-r-while'." - (declare (debug (form form body)) - (indent 2)) - (let ((v (make-symbol "vector"))) + "Eval BODY for each item in reversed LIST, while PRED evals to non-nil. +Each element of LIST in turn, starting at its end, is bound to +`it' and its index within LIST to `it-index' before evaluating +PRED or BODY. Once an element is reached for which PRED +evaluates to nil, no further BODY is evaluated. The return value +is always nil. +This is the anaphoric counterpart to `-each-r-while'." + (declare (debug (form form body)) (indent 2)) + (let ((v (make-symbol "vector")) + (i (make-symbol "i")) + (elt (make-symbol "elt"))) `(let* ((,v (vconcat ,list)) - (it-index (length ,v)) - it) - (while (> it-index 0) - (setq it-index (1- it-index)) - (setq it (aref ,v it-index)) - (if (not ,pred) - (setq it-index -1) - ,@body))))) + (,i (length ,v)) + ,elt it it-index) + (ignore it it-index) + (while (when (> ,i 0) + (setq ,i (1- ,i) it-index ,i) + (setq ,elt (aref ,v ,i) it ,elt) + ,pred) + (setq it-index ,i it ,elt) + ,@body)))) (defun -each-r-while (list pred fn) - "Call FN with every item in reversed LIST while (PRED item) is non-nil. -Return nil, used for side-effects only." + "Call FN on each ITEM in reversed LIST, while (PRED ITEM) is non-nil. +Once an ITEM is reached for which PRED returns nil, FN is no +longer called. Return nil; this function is intended for side +effects. +Its anaphoric counterpart is `--each-r-while'." (--each-r-while list (funcall pred it) (funcall fn it))) (defmacro --dotimes (num &rest body) - "Repeatedly executes BODY (presumably for side-effects) with symbol `it' bound to integers from 0 through NUM-1." - (declare (debug (form body)) - (indent 1)) - (let ((n (make-symbol "num"))) + "Evaluate BODY NUM times, presumably for side effects. +BODY is evaluated with the local variable `it' temporarily bound +to successive integers running from 0, inclusive, to NUM, +exclusive. BODY is not evaluated if NUM is less than 1. +This is the anaphoric counterpart to `-dotimes'." + (declare (debug (form body)) (indent 1)) + (let ((n (make-symbol "num")) + (i (make-symbol "i"))) `(let ((,n ,num) - (it 0)) - (while (< it ,n) - ,@body - (setq it (1+ it)))))) + (,i 0) + it) + (ignore it) + (while (< ,i ,n) + (setq it ,i ,i (1+ ,i)) + ,@body)))) (defun -dotimes (num fn) - "Repeatedly calls FN (presumably for side-effects) passing in integers from 0 through NUM-1." + "Call FN NUM times, presumably for side effects. +FN is called with a single argument on successive integers +running from 0, inclusive, to NUM, exclusive. FN is not called +if NUM is less than 1. +This function's anaphoric counterpart is `--dotimes'." + (declare (indent 1)) (--dotimes num (funcall fn it))) -(put '-dotimes 'lisp-indent-function 1) - (defun -map (fn list) - "Return a new list consisting of the result of applying FN to the items in LIST." + "Apply FN to each item in LIST and return the list of results. +This function's anaphoric counterpart is `--map'." (mapcar fn list)) (defmacro --map (form list) - "Anaphoric form of `-map'." + "Eval FORM for each item in LIST and return the list of results. +Each element of LIST in turn is bound to `it' before evaluating +BODY. +This is the anaphoric counterpart to `-map'." (declare (debug (form form))) - `(mapcar (lambda (it) ,form) ,list)) + (let ((l (make-symbol "list")) + (r (make-symbol "res"))) + `(let ((,l ,list) ,r it) + (ignore it) + (while ,l + (setq it (pop ,l)) + (push ,form ,r)) + (nreverse ,r)))) -(defmacro --reduce-from (form initial-value list) - "Anaphoric form of `-reduce-from'." +(defmacro --reduce-from (form init list) + "Accumulate a value by evaluating FORM across LIST. +This macro is like `--each' (which see), but it additionally +provides an accumulator variable `acc' which it successively +binds to the result of evaluating FORM for the current LIST +element before processing the next element. For the first +element, `acc' is initialized with the result of evaluating INIT. +The return value is the resulting value of `acc'. If LIST is +empty, FORM is not evaluated, and the return value is the result +of INIT. +This is the anaphoric counterpart to `-reduce-from'." (declare (debug (form form form))) - `(let ((acc ,initial-value)) + `(let ((acc ,init)) (--each ,list (setq acc ,form)) acc)) -(defun -reduce-from (fn initial-value list) - "Return the result of applying FN to INITIAL-VALUE and the -first item in LIST, then applying FN to that result and the 2nd -item, etc. If LIST contains no items, return INITIAL-VALUE and -do not call FN. +(defun -reduce-from (fn init list) + "Reduce the function FN across LIST, starting with INIT. +Return the result of applying FN to INIT and the first element of +LIST, then applying FN to that result and the second element, +etc. If LIST is empty, return INIT without calling FN. -In the anaphoric form `--reduce-from', the accumulated value is -exposed as symbol `acc'. - -See also: `-reduce', `-reduce-r'" - (--reduce-from (funcall fn acc it) initial-value list)) +This function's anaphoric counterpart is `--reduce-from'. +For other folds, see also `-reduce' and `-reduce-r'." + (--reduce-from (funcall fn acc it) init list)) (defmacro --reduce (form list) - "Anaphoric form of `-reduce'." + "Accumulate a value by evaluating FORM across LIST. +This macro is like `--reduce-from' (which see), except the first +element of LIST is taken as INIT. Thus if LIST contains a single +item, it is returned without evaluating FORM. If LIST is empty, +FORM is evaluated with `it' and `acc' bound to nil. +This is the anaphoric counterpart to `-reduce'." (declare (debug (form form))) (let ((lv (make-symbol "list-value"))) `(let ((,lv ,list)) (if ,lv (--reduce-from ,form (car ,lv) (cdr ,lv)) - (let (acc it) ,form))))) + (let (acc it) + (ignore acc it) + ,form))))) (defun -reduce (fn list) - "Return the result of applying FN to the first 2 items in LIST, -then applying FN to that result and the 3rd item, etc. If LIST -contains no items, return the result of calling FN with no -arguments. If LIST contains a single item, return that item -and do not call FN. + "Reduce the function FN across LIST. +Return the result of applying FN to the first two elements of +LIST, then applying FN to that result and the third element, etc. +If LIST contains a single element, return it without calling FN. +If LIST is empty, return the result of calling FN with no +arguments. -In the anaphoric form `--reduce', the accumulated value is -exposed as symbol `acc'. - -See also: `-reduce-from', `-reduce-r'" +This function's anaphoric counterpart is `--reduce'. +For other folds, see also `-reduce-from' and `-reduce-r'." (if list (-reduce-from fn (car list) (cdr list)) (funcall fn))) -(defmacro --reduce-r-from (form initial-value list) - "Anaphoric version of `-reduce-r-from'." +(defmacro --reduce-r-from (form init list) + "Accumulate a value by evaluating FORM across LIST in reverse. +This macro is like `--reduce-from', except it starts from the end +of LIST. +This is the anaphoric counterpart to `-reduce-r-from'." (declare (debug (form form form))) - `(--reduce-from ,form ,initial-value (reverse ,list))) + `(let ((acc ,init)) + (--each-r ,list (setq acc ,form)) + acc)) -(defun -reduce-r-from (fn initial-value list) - "Replace conses with FN, nil with INITIAL-VALUE and evaluate -the resulting expression. If LIST is empty, INITIAL-VALUE is -returned and FN is not called. +(defun -reduce-r-from (fn init list) + "Reduce the function FN across LIST in reverse, starting with INIT. +Return the result of applying FN to the last element of LIST and +INIT, then applying FN to the second-to-last element and the +previous result of FN, etc. That is, the first argument of FN is +the current element, and its second argument the accumulated +value. If LIST is empty, return INIT without calling FN. -Note: this function works the same as `-reduce-from' but the -operation associates from right instead of from left. +This function is like `-reduce-from' but the operation associates +from the right rather than left. In other words, it starts from +the end of LIST and flips the arguments to FN. Conceptually, it +is like replacing the conses in LIST with applications of FN, and +its last link with INIT, and evaluating the resulting expression. -See also: `-reduce-r', `-reduce'" - (--reduce-r-from (funcall fn it acc) initial-value list)) +This function's anaphoric counterpart is `--reduce-r-from'. +For other folds, see also `-reduce-r' and `-reduce'." + (--reduce-r-from (funcall fn it acc) init list)) (defmacro --reduce-r (form list) - "Anaphoric version of `-reduce-r'." + "Accumulate a value by evaluating FORM across LIST in reverse order. +This macro is like `--reduce', except it starts from the end of +LIST. +This is the anaphoric counterpart to `-reduce-r'." (declare (debug (form form))) `(--reduce ,form (reverse ,list))) (defun -reduce-r (fn list) - "Replace conses with FN and evaluate the resulting expression. -The final nil is ignored. If LIST contains no items, return the -result of calling FN with no arguments. If LIST contains a single -item, return that item and do not call FN. + "Reduce the function FN across LIST in reverse. +Return the result of applying FN to the last two elements of +LIST, then applying FN to the third-to-last element and the +previous result of FN, etc. That is, the first argument of FN is +the current element, and its second argument the accumulated +value. If LIST contains a single element, return it without +calling FN. If LIST is empty, return the result of calling FN +with no arguments. -The first argument of FN is the new item, the second is the -accumulated value. +This function is like `-reduce' but the operation associates from +the right rather than left. In other words, it starts from the +end of LIST and flips the arguments to FN. Conceptually, it is +like replacing the conses in LIST with applications of FN, +ignoring its last link, and evaluating the resulting expression. -Note: this function works the same as `-reduce' but the operation -associates from right instead of from left. - -See also: `-reduce-r-from', `-reduce'" +This function's anaphoric counterpart is `--reduce-r'. +For other folds, see also `-reduce-r-from' and `-reduce'." (if list (--reduce-r (funcall fn it acc) list) (funcall fn))) +(defmacro --reductions-from (form init list) + "Return a list of FORM's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-from' (which see) is called with the same +arguments. +This is the anaphoric counterpart to `-reductions-from'." + (declare (debug (form form form))) + `(nreverse + (--reduce-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list ,init) + ,list))) + (defun -reductions-from (fn init list) - "Return a list of the intermediate values of the reduction. + "Return a list of FN's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-from' (which see) is called with the same +arguments. +This function's anaphoric counterpart is `--reductions-from'. +For other folds, see also `-reductions' and `-reductions-r'." + (--reductions-from (funcall fn acc it) init list)) -See `-reduce-from' for explanation of the arguments. - -See also: `-reductions', `-reductions-r', `-reduce-r'" - (nreverse (--reduce-from (cons (funcall fn (car acc) it) acc) (list init) list))) +(defmacro --reductions (form list) + "Return a list of FORM's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce' (which see) is called with the same arguments. +This is the anaphoric counterpart to `-reductions'." + (declare (debug (form form))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv ,list)) + (if ,lv + (--reductions-from ,form (car ,lv) (cdr ,lv)) + (let (acc it) + (ignore acc it) + (list ,form)))))) (defun -reductions (fn list) - "Return a list of the intermediate values of the reduction. + "Return a list of FN's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce' (which see) is called with the same arguments. +This function's anaphoric counterpart is `--reductions'. +For other folds, see also `-reductions' and `-reductions-r'." + (if list + (--reductions-from (funcall fn acc it) (car list) (cdr list)) + (list (funcall fn)))) -See `-reduce' for explanation of the arguments. - -See also: `-reductions-from', `-reductions-r', `-reduce-r'" - (and list (-reductions-from fn (car list) (cdr list)))) +(defmacro --reductions-r-from (form init list) + "Return a list of FORM's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-r-from' (which see) is called with the same +arguments. +This is the anaphoric counterpart to `-reductions-r-from'." + (declare (debug (form form form))) + `(--reduce-r-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list ,init) + ,list)) (defun -reductions-r-from (fn init list) - "Return a list of the intermediate values of the reduction. + "Return a list of FN's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-r-from' (which see) is called with the same +arguments. +This function's anaphoric counterpart is `--reductions-r-from'. +For other folds, see also `-reductions' and `-reductions-r'." + (--reductions-r-from (funcall fn it acc) init list)) -See `-reduce-r-from' for explanation of the arguments. - -See also: `-reductions-r', `-reductions', `-reduce'" - (--reduce-r-from (cons (funcall fn it (car acc)) acc) (list init) list)) +(defmacro --reductions-r (form list) + "Return a list of FORM's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-re' (which see) is called with the same arguments. +This is the anaphoric counterpart to `-reductions-r'." + (declare (debug (form list))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv (reverse ,list))) + (if ,lv + (--reduce-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list (car ,lv)) + (cdr ,lv)) + (let (acc it) + (ignore acc it) + (list ,form)))))) (defun -reductions-r (fn list) - "Return a list of the intermediate values of the reduction. - -See `-reduce-r' for explanation of the arguments. - -See also: `-reductions-r-from', `-reductions', `-reduce'" - (when list - (let ((rev (reverse list))) - (--reduce-from (cons (funcall fn it (car acc)) acc) - (list (car rev)) - (cdr rev))))) + "Return a list of FN's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-r' (which see) is called with the same arguments. +This function's anaphoric counterpart is `--reductions-r'. +For other folds, see also `-reductions-r-from' and +`-reductions'." + (if list + (--reductions-r (funcall fn it acc) list) + (list (funcall fn)))) (defmacro --filter (form list) "Anaphoric form of `-filter'. @@ -530,6 +627,26 @@ See also: `-map-last'" Thus function FN should return a list." (--mapcat (funcall fn it) list)) +(defmacro --iterate (form init n) + "Anaphoric version of `-iterate'." + (declare (debug (form form form))) + (let ((res (make-symbol "result"))) + `(let ((it ,init) ,res) + (dotimes (_ ,n) + (push it ,res) + (setq it ,form)) + (nreverse ,res)))) + +(defun -iterate (fun init n) + "Return a list of iterated applications of FUN to INIT. + +This means a list of the form: + + (INIT (FUN INIT) (FUN (FUN INIT)) ...) + +N is the length of the returned list." + (--iterate (funcall fun it) init n)) + (defun -flatten (l) "Take a nested list L and return its contents as a single, flat list. @@ -547,11 +664,6 @@ See also: `-flatten-n'" (-mapcat '-flatten l) (list l))) -(defmacro --iterate (form init n) - "Anaphoric version of `-iterate'." - (declare (debug (form form form))) - `(-iterate (lambda (it) ,form) ,init ,n)) - (defun -flatten-n (num list) "Flatten NUM levels of a nested LIST. @@ -603,12 +715,17 @@ See also: `-splice', `-insert-at'" (defun -cons* (&rest args) "Make a new list from the elements of ARGS. - -The last 2 members of ARGS are used as the final cons of the -result so if the final member of ARGS is not a list the result is -a dotted list." +The last 2 elements of ARGS are used as the final cons of the +result, so if the final element of ARGS is not a list, the result +is a dotted list. With no ARGS, return nil." (declare (pure t) (side-effect-free t)) - (-reduce-r 'cons args)) + (let* ((len (length args)) + (tail (nthcdr (- len 2) args)) + (last (cdr tail))) + (if (null last) + (car args) + (setcdr tail (car last)) + args))) (defun -snoc (list elem &rest elements) "Append ELEM to the end of the list. @@ -743,9 +860,10 @@ See also: `-last-item'." "Counts the number of items in LIST where (PRED item) is non-nil." (--count (funcall pred it) list)) -(defun ---truthy? (val) +(defun ---truthy? (obj) + "Return OBJ as a boolean value (t or nil)." (declare (pure t) (side-effect-free t)) - (not (null val))) + (and obj t)) (defmacro --any? (form list) "Anaphoric form of `-any?'." @@ -847,73 +965,95 @@ section is returned. Defaults to 1." (push it new-list))) (nreverse new-list))) -(defun -take (n list) - "Return a new list of the first N items in LIST, or all items if there are fewer than N. - -See also: `-take-last'" - (declare (pure t) (side-effect-free t)) - (let (result) - (--dotimes n - (when list - (!cons (car list) result) - (!cdr list))) - (nreverse result))) - -(defun -take-last (n list) - "Return the last N items of LIST in order. - -See also: `-take'" - (declare (pure t) (side-effect-free t)) - (copy-sequence (last list n))) - -(defalias '-drop 'nthcdr - "Return the tail of LIST without the first N items. - -See also: `-drop-last' - -\(fn N LIST)") - -(defun -drop-last (n list) - "Remove the last N items of LIST and return a copy. - -See also: `-drop'" - ;; No alias because we don't want magic optional argument - (declare (pure t) (side-effect-free t)) - (butlast list n)) - (defmacro --take-while (form list) - "Anaphoric form of `-take-while'." + "Take successive items from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. Return a new +list of the successive elements from the start of LIST for which +FORM evaluates to non-nil. +This is the anaphoric counterpart to `-take-while'." (declare (debug (form form))) (let ((r (make-symbol "result"))) `(let (,r) - (--each-while ,list ,form (!cons it ,r)) + (--each-while ,list ,form (push it ,r)) (nreverse ,r)))) (defun -take-while (pred list) - "Return a new list of successive items from LIST while (PRED item) returns a non-nil value." + "Take successive items from LIST for which PRED returns non-nil. +PRED is a function of one argument. Return a new list of the +successive elements from the start of LIST for which PRED returns +non-nil. +This function's anaphoric counterpart is `--take-while'. +For another variant, see also `-drop-while'." (--take-while (funcall pred it) list)) (defmacro --drop-while (form list) - "Anaphoric form of `-drop-while'." + "Drop successive items from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. Return the +tail (not a copy) of LIST starting from its first element for +which FORM evaluates to nil. +This is the anaphoric counterpart to `-drop-while'." (declare (debug (form form))) (let ((l (make-symbol "list"))) `(let ((,l ,list)) - (while (and ,l (let ((it (car ,l))) ,form)) - (!cdr ,l)) + (--each-while ,l ,form (pop ,l)) ,l))) (defun -drop-while (pred list) - "Return the tail of LIST starting from the first item for which (PRED item) returns nil." + "Drop successive items from LIST for which PRED returns non-nil. +PRED is a function of one argument. Return the tail (not a copy) +of LIST starting from its first element for which PRED returns +nil. +This function's anaphoric counterpart is `--drop-while'. +For another variant, see also `-take-while'." (--drop-while (funcall pred it) list)) +(defun -take (n list) + "Return a copy of the first N items in LIST. +Return a copy of LIST if it contains N items or fewer. +Return nil if N is zero or less. + +See also: `-take-last'." + (declare (pure t) (side-effect-free t)) + (--take-while (< it-index n) list)) + +(defun -take-last (n list) + "Return a copy of the last N items of LIST in order. +Return a copy of LIST if it contains N items or fewer. +Return nil if N is zero or less. + +See also: `-take'." + (declare (pure t) (side-effect-free t)) + (copy-sequence (last list n))) + +(defalias '-drop #'nthcdr + "Return the tail (not a copy) of LIST without the first N items. +Return nil if LIST contains N items or fewer. +Return LIST if N is zero or less. +For another variant, see also `-drop-last'. +\n(fn N LIST)") + +(defun -drop-last (n list) + "Return a copy of LIST without its last N items. +Return a copy of LIST if N is zero or less. +Return nil if LIST contains N items or fewer. + +See also: `-drop'." + (declare (pure t) (side-effect-free t)) + (nbutlast (copy-sequence list) n)) + (defun -split-at (n list) - "Return a list of ((-take N LIST) (-drop N LIST)), in no more than one pass through the list." + "Split LIST into two sublists after the Nth element. +The result is a list of two elements (TAKE DROP) where TAKE is a +new list of the first N elements of LIST, and DROP is the +remaining elements of LIST (not a copy). TAKE and DROP are like +the results of `-take' and `-drop', respectively, but the split +is done in a single list traversal." (declare (pure t) (side-effect-free t)) (let (result) - (--dotimes n - (when list - (!cons (car list) result) - (!cdr list))) + (--each-while list (< it-index n) + (push (pop list) result)) (list (nreverse result) list))) (defun -rotate (n list) @@ -924,7 +1064,7 @@ The time complexity is O(n)." (let* ((len (length list)) (n-mod-len (mod n len)) (new-tail-len (- len n-mod-len))) - (append (-drop new-tail-len list) (-take new-tail-len list))))) + (append (nthcdr new-tail-len list) (-take new-tail-len list))))) (defun -insert-at (n x list) "Return a list with X inserted into LIST at position N. @@ -1047,28 +1187,29 @@ This function can be thought of as a generalization of "Return a list of ((-filter PRED LIST) (-remove PRED LIST)), in one pass through the list." (--separate (funcall pred it) list)) -(defun ---partition-all-in-steps-reversed (n step list) - "Private: Used by -partition-all-in-steps and -partition-in-steps." +(defun dash--partition-all-in-steps-reversed (n step list) + "Used by `-partition-all-in-steps' and `-partition-in-steps'." (when (< step 1) - (error "Step must be a positive number, or you're looking at some juicy infinite loops.")) - (let ((result nil)) + (signal 'wrong-type-argument + `("Step size < 1 results in juicy infinite loops" ,step))) + (let (result) (while list - (!cons (-take n list) result) - (setq list (-drop step list))) + (push (-take n list) result) + (setq list (nthcdr step list))) result)) (defun -partition-all-in-steps (n step list) "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart. The last groups may contain less than N items." (declare (pure t) (side-effect-free t)) - (nreverse (---partition-all-in-steps-reversed n step list))) + (nreverse (dash--partition-all-in-steps-reversed n step list))) (defun -partition-in-steps (n step list) "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart. If there are not enough items to make the last group N-sized, those items are discarded." (declare (pure t) (side-effect-free t)) - (let ((result (---partition-all-in-steps-reversed n step list))) + (let ((result (dash--partition-all-in-steps-reversed n step list))) (while (and result (< (length (car result)) n)) (!cdr result)) (nreverse result))) @@ -1328,16 +1469,18 @@ a variable number of arguments, such that is identity (given that the lists are the same length). Note in particular that calling this on a list of two lists will -return a list of cons-cells such that the aboce identity works. +return a list of cons-cells such that the above identity works. See also: `-zip'" (apply '-zip lists)) (defun -cycle (list) - "Return an infinite copy of LIST that will cycle through the -elements and repeat from the beginning." + "Return an infinite circular copy of LIST. +The returned list cycles through the elements of LIST and repeats +from the beginning." (declare (pure t) (side-effect-free t)) - (let ((newlist (-map 'identity list))) + ;; Also works with sequences that aren't lists. + (let ((newlist (append list ()))) (nconc newlist newlist))) (defun -pad (fill-value &rest lists) @@ -1540,7 +1683,7 @@ last item in second form, etc." Insert X at the position signified by the symbol `it' in the first form. If there are more forms, insert the first form at the position signified by `it' in in second form, etc." - (declare (debug (form body))) + (declare (debug (form body)) (indent 1)) `(-as-> ,x it ,@forms)) (defmacro -as-> (value variable &rest forms) @@ -1581,7 +1724,7 @@ and when that result is non-nil, through the next form, etc." ,@more)))) (defmacro -some--> (x &optional form &rest more) - "When expr in non-nil, thread it through the first form (via `-->'), + "When expr is non-nil, thread it through the first form (via `-->'), and when that result is non-nil, through the next form, etc." (declare (debug ->) (indent 1)) @@ -1591,25 +1734,42 @@ and when that result is non-nil, through the next form, etc." (--> ,result ,form)) ,@more)))) +(defmacro -doto (init &rest forms) + "Evaluate INIT and pass it as argument to FORMS with `->'. +The RESULT of evaluating INIT is threaded through each of FORMS +individually using `->', which see. The return value is RESULT, +which FORMS may have modified by side effect." + (declare (debug (form body)) (indent 1)) + (let ((retval (make-symbol "result"))) + `(let ((,retval ,init)) + ,@(mapcar (lambda (form) `(-> ,retval ,form)) forms) + ,retval))) + +(defmacro --doto (init &rest forms) + "Anaphoric form of `-doto'. +This just evaluates INIT, binds the result to `it', evaluates +FORMS, and returns the final value of `it'. +Note: `it' need not be used in each form." + (declare (debug (form body)) (indent 1)) + `(let ((it ,init)) + ,@forms + it)) + (defun -grade-up (comparator list) - "Grade elements of LIST using COMPARATOR relation, yielding a -permutation vector such that applying this permutation to LIST -sorts it in ascending order." - ;; ugly hack to "fix" lack of lexical scope - (let ((comp `(lambda (it other) (funcall ',comparator (car it) (car other))))) - (->> (--map-indexed (cons it it-index) list) - (-sort comp) - (-map 'cdr)))) + "Grade elements of LIST using COMPARATOR relation. +This yields a permutation vector such that applying this +permutation to LIST sorts it in ascending order." + (->> (--map-indexed (cons it it-index) list) + (-sort (lambda (it other) (funcall comparator (car it) (car other)))) + (mapcar #'cdr))) (defun -grade-down (comparator list) - "Grade elements of LIST using COMPARATOR relation, yielding a -permutation vector such that applying this permutation to LIST -sorts it in descending order." - ;; ugly hack to "fix" lack of lexical scope - (let ((comp `(lambda (it other) (funcall ',comparator (car other) (car it))))) - (->> (--map-indexed (cons it it-index) list) - (-sort comp) - (-map 'cdr)))) + "Grade elements of LIST using COMPARATOR relation. +This yields a permutation vector such that applying this +permutation to LIST sorts it in descending order." + (->> (--map-indexed (cons it it-index) list) + (-sort (lambda (it other) (funcall comparator (car other) (car it)))) + (mapcar #'cdr))) (defvar dash--source-counter 0 "Monotonic counter for generated symbols.") @@ -1717,17 +1877,6 @@ SOURCE is a proper or improper list." (t ;; Handle improper lists. Last matching place, no need for shift (dash--match match-form (dash--match-cons-get-cdr skip-cdr source)))))) -(defun dash--vector-tail (seq start) - "Return the tail of SEQ starting at START." - (cond - ((vectorp seq) - (let* ((re-length (- (length seq) start)) - (re (make-vector re-length 0))) - (--dotimes re-length (aset re it (aref seq (+ it start)))) - re)) - ((stringp seq) - (substring seq start)))) - (defun dash--match-vector (match-form source) "Setup a vector matching environment and call the real matcher." (let ((s (dash--match-make-source-symbol))) @@ -1775,7 +1924,7 @@ is discarded." (eq m '&rest)) (prog1 (dash--match (aref match-form (1+ i)) - `(dash--vector-tail ,source ,i)) + `(substring ,source ,i)) (setq i l))) ((and (symbolp m) ;; do not match symbols starting with _ @@ -1926,7 +2075,7 @@ Key-value stores are disambiguated by placing a token &plist, (eq '&as (aref match-form 1))) (let ((s (aref match-form 0))) (cons (list s source) - (dash--match (dash--vector-tail match-form 2) s)))) + (dash--match (substring match-form 2) s)))) (t (dash--match-vector match-form source)))))) (defun dash--normalize-let-varlist (varlist) @@ -1978,11 +2127,11 @@ If VARLIST only contains one (PATTERN SOURCE) element, you can optionally specify it using a vector and discarding the outer-most parens. Thus - (-let ((PATTERN SOURCE)) ..) + (-let ((PATTERN SOURCE)) ...) becomes - (-let [PATTERN SOURCE] ..). + (-let [PATTERN SOURCE] ...). `-let' uses a convention of not binding places (symbols) starting with _ whenever it's possible. You can use this to skip over @@ -2007,7 +2156,7 @@ Conses and lists: (a b) - bind car of list to A and `cadr' to B - (a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3 ... + (a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3... (a1 a2 a3 ... aN . rest) - as above, but bind the Nth cdr to REST. @@ -2146,27 +2295,28 @@ such that: (-lambda (x y ...) body) has the usual semantics of `lambda'. Furthermore, these get -translated into normal lambda, so there is no performance +translated into normal `lambda', so there is no performance penalty. -See `-let' for the description of destructuring mechanism." +See `-let' for a description of the destructuring mechanism." (declare (doc-string 2) (indent defun) (debug (&define sexp [&optional stringp] [&optional ("interactive" interactive)] def-body))) (cond - ((not (consp match-form)) - (signal 'wrong-type-argument "match-form must be a list")) - ;; no destructuring, so just return regular lambda to make things faster - ((-all? 'symbolp match-form) + ((nlistp match-form) + (signal 'wrong-type-argument (list #'listp match-form))) + ;; No destructuring, so just return regular `lambda' for speed. + ((-all? #'symbolp match-form) `(lambda ,match-form ,@body)) - (t - (let* ((inputs (--map-indexed (list it (make-symbol (format "input%d" it-index))) match-form))) - ;; TODO: because inputs to the lambda are evaluated only once, - ;; -let* need not to create the extra bindings to ensure that. + ((let ((inputs (--map-indexed + (list it (make-symbol (format "input%d" it-index))) + match-form))) + ;; TODO: because inputs to the `lambda' are evaluated only once, + ;; `-let*' need not create the extra bindings to ensure that. ;; We should find a way to optimize that. Not critical however. - `(lambda ,(--map (cadr it) inputs) + `(lambda ,(mapcar #'cadr inputs) (-let* ,inputs ,@body)))))) (defmacro -setq (&rest forms) @@ -2193,7 +2343,7 @@ multiple assignments it does not cause unexpected side effects. (declare (debug (&rest sexp form)) (indent 1)) (when (= (mod (length forms) 2) 1) - (error "Odd number of arguments")) + (signal 'wrong-number-of-arguments (list '-setq (1+ (length forms))))) (let* ((forms-and-sources ;; First get all the necessary mappings with all the ;; intermediate bindings. @@ -2470,22 +2620,24 @@ if the first element should sort before the second." (declare (debug (form form))) `(-sort (lambda (it other) ,form) ,list)) -(defun -list (&rest args) - "Return a list with ARGS. +(defun -list (&optional arg &rest args) + "Ensure ARG is a list. +If ARG is already a list, return it as is (not a copy). +Otherwise, return a new list with ARG as its only element. -If first item of ARGS is already a list, simply return ARGS. If -not, return a list with ARGS as elements." - (declare (pure t) (side-effect-free t)) - (let ((arg (car args))) - (if (listp arg) arg args))) +Another supported calling convention is (-list &rest ARGS). +In this case, if ARG is not a list, a new list with all of +ARGS as elements is returned. This use is supported for +backward compatibility and is otherwise deprecated." + (declare (advertised-calling-convention (arg) "2.18.0") + (pure t) (side-effect-free t)) + (if (listp arg) arg (cons arg args))) (defun -repeat (n x) - "Return a list with X repeated N times. + "Return a new list of length N with each element being X. Return nil if N is less than 1." (declare (pure t) (side-effect-free t)) - (let (ret) - (--dotimes n (!cons x ret)) - ret)) + (and (natnump n) (make-list n x))) (defun -sum (list) "Return the sum of LIST." @@ -2494,12 +2646,10 @@ Return nil if N is less than 1." (defun -running-sum (list) "Return a list with running sums of items in LIST. - LIST must be non-empty." (declare (pure t) (side-effect-free t)) - (unless (consp list) - (error "LIST must be non-empty")) - (-reductions '+ list)) + (or list (signal 'wrong-type-argument (list #'consp list))) + (-reductions #'+ list)) (defun -product (list) "Return the product of LIST." @@ -2508,12 +2658,10 @@ LIST must be non-empty." (defun -running-product (list) "Return a list with running products of items in LIST. - LIST must be non-empty." (declare (pure t) (side-effect-free t)) - (unless (consp list) - (error "LIST must be non-empty")) - (-reductions '* list)) + (or list (signal 'wrong-type-argument (list #'consp list))) + (-reductions #'* list)) (defun -max (list) "Return the largest value from LIST of numbers or markers." @@ -2555,19 +2703,20 @@ The items for the comparator form are exposed as \"it\" and \"other\"." (declare (debug (form form))) `(-min-by (lambda (it other) ,form) ,list)) -(defun -iterate (fun init n) - "Return a list of iterated applications of FUN to INIT. - -This means a list of form: - - (init (fun init) (fun (fun init)) ...) - -N is the length of the returned list." - (if (= n 0) nil - (let ((r (list init))) - (--dotimes (1- n) - (push (funcall fun (car r)) r)) - (nreverse r)))) +(defun -iota (count &optional start step) + "Return a list containing COUNT numbers. +Starts from START and adds STEP each time. The default START is +zero, the default STEP is 1. +This function takes its name from the corresponding primitive in +the APL language." + (declare (pure t) (side-effect-free t)) + (unless (natnump count) + (signal 'wrong-type-argument (list #'natnump count))) + (or start (setq start 0)) + (or step (setq step 1)) + (if (zerop step) + (make-list count start) + (--iterate (+ it step) start count))) (defun -fix (fn list) "Compute the (least) fixpoint of FN with initial input LIST. @@ -2604,14 +2753,12 @@ the new seed." (declare (debug (form form))) `(-unfold (lambda (it) ,form) ,seed)) -(defun -cons-pair? (con) - "Return non-nil if CON is true cons pair. -That is (A . B) where B is not a list. - -Alias: `-cons-pair-p'" +(defun -cons-pair? (obj) + "Return non-nil if OBJ is a true cons pair. +That is, a cons (A . B) where B is not a list. +Alias: `-cons-pair-p'." (declare (pure t) (side-effect-free t)) - (and (listp con) - (not (listp (cdr con))))) + (nlistp (cdr-safe obj))) (defalias '-cons-pair-p '-cons-pair?) @@ -2774,299 +2921,195 @@ replaced with new ones. This is useful when you need to clone a structure such as plist or alist." (declare (pure t) (side-effect-free t)) (-tree-map 'identity list)) + +;;; Font lock -(defun dash-enable-font-lock () - "Add syntax highlighting to dash functions, macros and magic values." - (eval-after-load 'lisp-mode - '(progn - (let ((new-keywords '( - "!cons" - "!cdr" - "-each" - "--each" - "-each-indexed" - "--each-indexed" - "-each-while" - "--each-while" - "-doto" - "-dotimes" - "--dotimes" - "-map" - "--map" - "-reduce-from" - "--reduce-from" - "-reduce" - "--reduce" - "-reduce-r-from" - "--reduce-r-from" - "-reduce-r" - "--reduce-r" - "-reductions-from" - "-reductions-r-from" - "-reductions" - "-reductions-r" - "-filter" - "--filter" - "-select" - "--select" - "-remove" - "--remove" - "-reject" - "--reject" - "-remove-first" - "--remove-first" - "-reject-first" - "--reject-first" - "-remove-last" - "--remove-last" - "-reject-last" - "--reject-last" - "-remove-item" - "-non-nil" - "-keep" - "--keep" - "-map-indexed" - "--map-indexed" - "-splice" - "--splice" - "-splice-list" - "--splice-list" - "-map-when" - "--map-when" - "-replace-where" - "--replace-where" - "-map-first" - "--map-first" - "-map-last" - "--map-last" - "-replace" - "-replace-first" - "-replace-last" - "-flatten" - "-flatten-n" - "-concat" - "-mapcat" - "--mapcat" - "-copy" - "-cons*" - "-snoc" - "-first" - "--first" - "-find" - "--find" - "-some" - "--some" - "-any" - "--any" - "-last" - "--last" - "-first-item" - "-second-item" - "-third-item" - "-fourth-item" - "-fifth-item" - "-last-item" - "-butlast" - "-count" - "--count" - "-any?" - "--any?" - "-some?" - "--some?" - "-any-p" - "--any-p" - "-some-p" - "--some-p" - "-some->" - "-some->>" - "-some-->" - "-all?" - "-all-p" - "--all?" - "--all-p" - "-every?" - "--every?" - "-all-p" - "--all-p" - "-every-p" - "--every-p" - "-none?" - "--none?" - "-none-p" - "--none-p" - "-only-some?" - "--only-some?" - "-only-some-p" - "--only-some-p" - "-slice" - "-take" - "-drop" - "-drop-last" - "-take-last" - "-take-while" - "--take-while" - "-drop-while" - "--drop-while" - "-split-at" - "-rotate" - "-insert-at" - "-replace-at" - "-update-at" - "--update-at" - "-remove-at" - "-remove-at-indices" - "-split-with" - "--split-with" - "-split-on" - "-split-when" - "--split-when" - "-separate" - "--separate" - "-partition-all-in-steps" - "-partition-in-steps" - "-partition-all" - "-partition" - "-partition-after-item" - "-partition-after-pred" - "-partition-before-item" - "-partition-before-pred" - "-partition-by" - "--partition-by" - "-partition-by-header" - "--partition-by-header" - "-group-by" - "--group-by" - "-interpose" - "-interleave" - "-unzip" - "-zip-with" - "--zip-with" - "-zip" - "-zip-fill" - "-zip-lists" - "-zip-pair" - "-cycle" - "-pad" - "-annotate" - "--annotate" - "-table" - "-table-flat" - "-partial" - "-elem-index" - "-elem-indices" - "-find-indices" - "--find-indices" - "-find-index" - "--find-index" - "-find-last-index" - "--find-last-index" - "-select-by-indices" - "-select-columns" - "-select-column" - "-grade-up" - "-grade-down" - "->" - "->>" - "-->" - "-as->" - "-when-let" - "-when-let*" - "--when-let" - "-if-let" - "-if-let*" - "--if-let" - "-let*" - "-let" - "-lambda" - "-distinct" - "-uniq" - "-union" - "-intersection" - "-difference" - "-powerset" - "-permutations" - "-inits" - "-tails" - "-common-prefix" - "-common-suffix" - "-contains?" - "-contains-p" - "-same-items?" - "-same-items-p" - "-is-prefix-p" - "-is-prefix?" - "-is-suffix-p" - "-is-suffix?" - "-is-infix-p" - "-is-infix?" - "-sort" - "--sort" - "-list" - "-repeat" - "-sum" - "-running-sum" - "-product" - "-running-product" - "-max" - "-min" - "-max-by" - "--max-by" - "-min-by" - "--min-by" - "-iterate" - "--iterate" - "-fix" - "--fix" - "-unfold" - "--unfold" - "-cons-pair?" - "-cons-pair-p" - "-cons-to-list" - "-value-to-list" - "-tree-mapreduce-from" - "--tree-mapreduce-from" - "-tree-mapreduce" - "--tree-mapreduce" - "-tree-map" - "--tree-map" - "-tree-reduce-from" - "--tree-reduce-from" - "-tree-reduce" - "--tree-reduce" - "-tree-seq" - "--tree-seq" - "-tree-map-nodes" - "--tree-map-nodes" - "-clone" - "-rpartial" - "-juxt" - "-applify" - "-on" - "-flip" - "-const" - "-cut" - "-orfn" - "-andfn" - "-iteratefn" - "-fixfn" - "-prodfn" - )) - (special-variables '( - "it" - "it-index" - "acc" - "other" - ))) - (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "\\_<" (regexp-opt special-variables 'paren) "\\_>") - 1 font-lock-variable-name-face)) 'append) - (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "(\\s-*" (regexp-opt new-keywords 'paren) "\\_>") - 1 font-lock-keyword-face)) 'append)) - (--each (buffer-list) - (with-current-buffer it - (when (and (eq major-mode 'emacs-lisp-mode) - (boundp 'font-lock-mode) - font-lock-mode) - (font-lock-refresh-defaults))))))) +(defvar dash--keywords + `(;; TODO: Do not fontify the following automatic variables + ;; globally; detect and limit to their local anaphoric scope. + (,(concat "\\_<" (regexp-opt '("acc" "it" "it-index" "other")) "\\_>") + 0 font-lock-variable-name-face) + ;; Elisp macro fontification was static prior to Emacs 25. + ,@(when (< emacs-major-version 25) + (let ((macs '("!cdr" + "!cons" + "-->" + "--all?" + "--annotate" + "--any?" + "--count" + "--dotimes" + "--doto" + "--drop-while" + "--each" + "--each-r" + "--each-r-while" + "--each-while" + "--filter" + "--find-index" + "--find-indices" + "--find-last-index" + "--first" + "--fix" + "--group-by" + "--if-let" + "--iterate" + "--keep" + "--last" + "--map" + "--map-first" + "--map-indexed" + "--map-last" + "--map-when" + "--mapcat" + "--max-by" + "--min-by" + "--none?" + "--only-some?" + "--partition-by" + "--partition-by-header" + "--reduce" + "--reduce-from" + "--reduce-r" + "--reduce-r-from" + "--reductions" + "--reductions-from" + "--reductions-r" + "--reductions-r-from" + "--remove" + "--remove-first" + "--remove-last" + "--separate" + "--some" + "--sort" + "--splice" + "--splice-list" + "--split-when" + "--split-with" + "--take-while" + "--tree-map" + "--tree-map-nodes" + "--tree-mapreduce" + "--tree-mapreduce-from" + "--tree-reduce" + "--tree-reduce-from" + "--tree-seq" + "--unfold" + "--update-at" + "--when-let" + "--zip-with" + "->" + "->>" + "-as->" + "-doto" + "-if-let" + "-if-let*" + "-lambda" + "-let" + "-let*" + "-setq" + "-some-->" + "-some->" + "-some->>" + "-split-on" + "-when-let" + "-when-let*"))) + `((,(concat "(" (regexp-opt macs 'symbols)) . 1))))) + "Font lock keywords for `dash-fontify-mode'.") + +(defcustom dash-fontify-mode-lighter nil + "Mode line lighter for `dash-fontify-mode'. +Either a string to display in the mode line when +`dash-fontify-mode' is on, or nil to display +nothing (the default)." + :package-version '(dash . "2.18.0") + :group 'dash + :type '(choice (string :tag "Lighter" :value " Dash") + (const :tag "Nothing" nil))) + +;;;###autoload +(define-minor-mode dash-fontify-mode + "Toggle fontification of Dash special variables. + +Dash-Fontify mode is a buffer-local minor mode intended for Emacs +Lisp buffers. Enabling it causes the special variables bound in +anaphoric Dash macros to be fontified. These anaphoras include +`it', `it-index', `acc', and `other'. In older Emacs versions +which do not dynamically detect macros, Dash-Fontify mode +additionally fontifies Dash macro calls. + +See also `dash-fontify-mode-lighter' and +`global-dash-fontify-mode'." + :group 'dash :lighter dash-fontify-mode-lighter + (if dash-fontify-mode + (font-lock-add-keywords nil dash--keywords t) + (font-lock-remove-keywords nil dash--keywords)) + (cond ((fboundp 'font-lock-flush) ;; Added in Emacs 25. + (font-lock-flush)) + ;; `font-lock-fontify-buffer' unconditionally enables + ;; `font-lock-mode' and is marked `interactive-only' in later + ;; Emacs versions which have `font-lock-flush', so we guard + ;; and pacify as needed, respectively. + (font-lock-mode + (with-no-warnings + (font-lock-fontify-buffer))))) + +(defun dash--turn-on-fontify-mode () + "Enable `dash-fontify-mode' if in an Emacs Lisp buffer." + (when (derived-mode-p #'emacs-lisp-mode) + (dash-fontify-mode))) + +;;;###autoload +(define-globalized-minor-mode global-dash-fontify-mode + dash-fontify-mode dash--turn-on-fontify-mode + :group 'dash) + +(defcustom dash-enable-fontlock nil + "If non-nil, fontify Dash macro calls and special variables." + :group 'dash + :set (lambda (sym val) + (set-default sym val) + (global-dash-fontify-mode (if val 1 0))) + :type 'boolean) + +(make-obsolete-variable + 'dash-enable-fontlock #'global-dash-fontify-mode "2.18.0") + +(define-obsolete-function-alias + 'dash-enable-font-lock #'global-dash-fontify-mode "2.18.0") + +;;; Info + +(defvar dash--info-doc-spec '("(dash) Index" nil "^ -+ .*: " "\\( \\|$\\)") + "The Dash :doc-spec entry for `info-lookup-alist'. +It is based on that for `emacs-lisp-mode'.") + +(defun dash--info-elisp-docs () + "Return the `emacs-lisp-mode' symbol docs from `info-lookup-alist'. +Specifically, return the cons containing their +`info-lookup->doc-spec' so that we can modify it." + (defvar info-lookup-alist) + (nthcdr 3 (assq #'emacs-lisp-mode (cdr (assq 'symbol info-lookup-alist))))) + +;;;###autoload +(defun dash-register-info-lookup () + "Register the Dash Info manual with `info-lookup-symbol'. +This allows Dash symbols to be looked up with \\[info-lookup-symbol]." + (interactive) + (require 'info-look) + (let ((docs (dash--info-elisp-docs))) + (setcar docs (append (car docs) (list dash--info-doc-spec))) + (info-lookup-reset))) + +(defun dash-unload-function () + "Remove Dash from `info-lookup-alist'. +Used by `unload-feature', which see." + (let ((docs (and (featurep 'info-look) + (dash--info-elisp-docs)))) + (when (member dash--info-doc-spec (car docs)) + (setcar docs (remove dash--info-doc-spec (car docs))) + (info-lookup-reset))) + nil) (provide 'dash) ;;; dash.el ends here diff --git a/core/libs/ht.el b/core/libs/ht.el index 6f7451cce..aaf785143 100644 --- a/core/libs/ht.el +++ b/core/libs/ht.el @@ -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 -;; 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"))) diff --git a/core/libs/ido-vertical-mode.el b/core/libs/ido-vertical-mode.el index 03224a24a..ac6a827d3 100644 --- a/core/libs/ido-vertical-mode.el +++ b/core/libs/ido-vertical-mode.el @@ -5,7 +5,6 @@ ;; Author: Steven Degutis ;; Maintainer: Christopher Reichert ;; 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 diff --git a/core/libs/package-build-badges.el b/core/libs/package-build-badges.el index fc736402d..2dae74d0b 100644 --- a/core/libs/package-build-badges.el +++ b/core/libs/package-build-badges.el @@ -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 ;; Copyright (C) 2012-2014 Steve Purcell @@ -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 diff --git a/core/libs/package-build.el b/core/libs/package-build.el index 56fc17163..af80a489f 100644 --- a/core/libs/package-build.el +++ b/core/libs/package-build.el @@ -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 -;; Copyright (C) 2012-2020 Steve Purcell -;; Copyright (C) 2016-2020 Jonas Bernoulli +;; Copyright (C) 2011-2021 Donald Ephraim Curtis +;; Copyright (C) 2012-2021 Steve Purcell +;; Copyright (C) 2016-2021 Jonas Bernoulli ;; Copyright (C) 2009 Phil Hagelberg ;; Author: Donald Ephraim Curtis ;; 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 diff --git a/core/libs/package-recipe-mode.el b/core/libs/package-recipe-mode.el index a9c1df9e5..78973661e 100644 --- a/core/libs/package-recipe-mode.el +++ b/core/libs/package-recipe-mode.el @@ -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 -;; Copyright (C) 2012-2014 Steve Purcell +;; Copyright (C) 2011-2020 Donald Ephraim Curtis +;; Copyright (C) 2012-2020 Steve Purcell +;; Copyright (C) 2016-2020 Jonas Bernoulli ;; Copyright (C) 2009 Phil Hagelberg ;; Author: Donald Ephraim Curtis @@ -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 diff --git a/core/libs/package-recipe.el b/core/libs/package-recipe.el index fab013420..a3200f8c5 100644 --- a/core/libs/package-recipe.el +++ b/core/libs/package-recipe.el @@ -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 @@ -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 diff --git a/core/libs/page-break-lines.el b/core/libs/page-break-lines.el index 7ec70facb..bc190e3e4 100644 --- a/core/libs/page-break-lines.el +++ b/core/libs/page-break-lines.el @@ -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 diff --git a/core/libs/quelpa.el b/core/libs/quelpa.el index 9ae9f2f4b..f220e6cca 100644 --- a/core/libs/quelpa.el +++ b/core/libs/quelpa.el @@ -4,10 +4,10 @@ ;; Copyright 2014-2015, Vasilij Schneidermann ;; 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 diff --git a/core/libs/spacemacs-theme/spacemacs-common.el b/core/libs/spacemacs-theme/spacemacs-common.el index 5f61b85bc..cbeac2b6f 100644 --- a/core/libs/spacemacs-theme/spacemacs-common.el +++ b/core/libs/spacemacs-theme/spacemacs-common.el @@ -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)))) diff --git a/core/libs/spinner.el b/core/libs/spinner.el index 2ec7d1fc8..6403deab4 100644 --- a/core/libs/spinner.el +++ b/core/libs/spinner.el @@ -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."