mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-06 06:20:55 -08:00
Avoid using pcase and many other macros in macro-expanded forms
This is related to https://github.com/jwiegley/use-package/issues/550
This commit is contained in:
John Wiegley
parent
a090961f10
commit
0a628a2767
5 changed files with 263 additions and 193 deletions
|
|
@ -237,14 +237,20 @@ function symbol (unquoted)."
|
|||
;; Process any initial keyword arguments
|
||||
(let ((cont t))
|
||||
(while (and cont args)
|
||||
(if (pcase (car args)
|
||||
(`:map (setq map (cadr args)))
|
||||
(`:prefix-docstring (setq doc (cadr args)))
|
||||
(`:prefix-map (setq prefix-map (cadr args)))
|
||||
(`:prefix (setq prefix (cadr args)))
|
||||
(`:filter (setq filter (cadr args)) t)
|
||||
(`:menu-name (setq menu-name (cadr args)))
|
||||
(`:package (setq pkg (cadr args))))
|
||||
(if (cond ((eq :map (car args))
|
||||
(setq map (cadr args)))
|
||||
((eq :prefix-docstring (car args))
|
||||
(setq doc (cadr args)))
|
||||
((eq :prefix-map (car args))
|
||||
(setq prefix-map (cadr args)))
|
||||
((eq :prefix (car args))
|
||||
(setq prefix (cadr args)))
|
||||
((eq :filter (car args))
|
||||
(setq filter (cadr args)) t)
|
||||
((eq :menu-name (car args))
|
||||
(setq menu-name (cadr args)))
|
||||
((eq :package (car args))
|
||||
(setq pkg (cadr args))))
|
||||
(setq args (cddr args))
|
||||
(setq cont nil))))
|
||||
|
||||
|
|
|
|||
|
|
@ -74,10 +74,8 @@ deferred until the prefix key sequence is pressed."
|
|||
(concat label " a (<string or vector> . <symbol, string or function>)"
|
||||
" or list of these")))
|
||||
(use-package-normalize-pairs
|
||||
#'(lambda (k)
|
||||
(pcase k
|
||||
((pred stringp) t)
|
||||
((pred vectorp) t)))
|
||||
#'(lambda (k) (cond ((stringp k) t)
|
||||
((vectorp k) t)))
|
||||
#'(lambda (v) (use-package-recognize-function v t #'stringp))
|
||||
name label arg))))
|
||||
|
||||
|
|
@ -91,8 +89,9 @@ deferred until the prefix key sequence is pressed."
|
|||
;;;###autoload
|
||||
(defun use-package-handler/:bind
|
||||
(name keyword args rest state &optional bind-macro)
|
||||
(cl-destructuring-bind (nargs . commands)
|
||||
(use-package-normalize-commands args)
|
||||
(let* ((result (use-package-normalize-commands args))
|
||||
(nargs (car result))
|
||||
(commands (cdr result)))
|
||||
(use-package-concat
|
||||
(use-package-process-keywords name
|
||||
(use-package-sort-keywords
|
||||
|
|
|
|||
|
|
@ -429,7 +429,7 @@ This is in contrast to merely setting it to 0."
|
|||
|
||||
(defun use-package-split-list (pred xs)
|
||||
(let ((ys (list nil)) (zs (list nil)) flip)
|
||||
(dolist (x xs)
|
||||
(cl-dolist (x xs)
|
||||
(if flip
|
||||
(nconc zs (list x))
|
||||
(if (funcall pred x)
|
||||
|
|
@ -445,12 +445,12 @@ This is in contrast to merely setting it to 0."
|
|||
;;
|
||||
|
||||
(defun use-package-keyword-index (keyword)
|
||||
(loop named outer
|
||||
(cl-loop named outer
|
||||
with index = 0
|
||||
for k in use-package-keywords do
|
||||
(if (eq k keyword)
|
||||
(return-from outer index))
|
||||
(incf index)))
|
||||
(cl-return-from outer index))
|
||||
(cl-incf index)))
|
||||
|
||||
(defun use-package-normalize-plist (name input &optional plist merge-function)
|
||||
"Given a pseudo-plist, normalize it to a regular plist.
|
||||
|
|
@ -492,11 +492,10 @@ extending any keys already present."
|
|||
args)
|
||||
|
||||
(defun use-package-merge-keys (key new old)
|
||||
(pcase key
|
||||
(`:if `(and ,new ,old))
|
||||
(`:after `(:all ,new ,old))
|
||||
(`:defer old)
|
||||
(_ (append new old))))
|
||||
(cond ((eq :if key) `(and ,new ,old))
|
||||
((eq :after key) `(:all ,new ,old))
|
||||
((eq :defer key) old)
|
||||
(t (append new old))))
|
||||
|
||||
(defun use-package-sort-keywords (plist)
|
||||
(let (plist-grouped)
|
||||
|
|
@ -505,7 +504,8 @@ extending any keys already present."
|
|||
plist-grouped)
|
||||
(setq plist (cddr plist)))
|
||||
(let (result)
|
||||
(dolist (x
|
||||
(cl-dolist
|
||||
(x
|
||||
(nreverse
|
||||
(sort plist-grouped
|
||||
#'(lambda (l r) (< (use-package-keyword-index (car l))
|
||||
|
|
@ -525,10 +525,11 @@ extending any keys already present."
|
|||
#'use-package-merge-keys))
|
||||
|
||||
;; Add default values for keywords not specified, when applicable.
|
||||
(dolist (spec use-package-defaults)
|
||||
(when (pcase (nth 2 spec)
|
||||
((and func (pred functionp)) (funcall func args))
|
||||
(sexp (eval sexp)))
|
||||
(cl-dolist (spec use-package-defaults)
|
||||
(when (let ((func (nth 2 spec)))
|
||||
(if (and func (functionp func))
|
||||
(funcall func args)
|
||||
(eval func)))
|
||||
(setq args (use-package-plist-maybe-put
|
||||
args (nth 0 spec) (eval (nth 1 spec))))))
|
||||
|
||||
|
|
@ -639,13 +640,14 @@ no more than once."
|
|||
(let ((loaded (cl-gensym "use-package--loaded"))
|
||||
(result (cl-gensym "use-package--result"))
|
||||
(next (cl-gensym "use-package--next")))
|
||||
`((lexical-let (,loaded ,result)
|
||||
(lexical-let ((,next (lambda ()
|
||||
`((defvar ,loaded nil)
|
||||
(defvar ,result nil)
|
||||
(defvar ,next #'(lambda ()
|
||||
(if ,loaded
|
||||
,result
|
||||
(setq ,loaded t)
|
||||
(setq ,result ,arg)))))
|
||||
,(funcall f ``(funcall ,,next)))))))
|
||||
(setq ,result ,arg))))
|
||||
,(funcall f `(funcall ,next)))))
|
||||
|
||||
(defsubst use-package-normalize-value (label arg)
|
||||
"Normalize a value."
|
||||
|
|
@ -718,7 +720,9 @@ no more than once."
|
|||
(use-package-error (concat label " wants a sexp or list of sexps")))
|
||||
(mapcar #'(lambda (form)
|
||||
(if (and (consp form)
|
||||
(eq (car form) 'use-package))
|
||||
(memq (car form)
|
||||
'(use-package bind-key bind-key*
|
||||
unbind-key bind-keys bind-keys*)))
|
||||
(macroexpand form)
|
||||
form)) args))
|
||||
|
||||
|
|
@ -763,28 +767,33 @@ If RECURSED is non-nil, recurse into sublists."
|
|||
(quote (lambda () ...))
|
||||
#'(lambda () ...)
|
||||
(function (lambda () ...))"
|
||||
(pcase v
|
||||
((and x (guard (if binding
|
||||
(symbolp x)
|
||||
(use-package-non-nil-symbolp x)))) t)
|
||||
(`(,(or `quote `function)
|
||||
,(pred use-package-non-nil-symbolp)) t)
|
||||
((and x (guard (if binding (commandp x) (functionp x)))) t)
|
||||
(_ (and additional-pred
|
||||
(funcall additional-pred v)))))
|
||||
(or (if binding
|
||||
(symbolp v)
|
||||
(use-package-non-nil-symbolp v))
|
||||
(and (listp v)
|
||||
(memq (car v) '(quote function))
|
||||
(use-package-non-nil-symbolp (cadr v)))
|
||||
(if binding (commandp v) (functionp v))
|
||||
(and additional-pred
|
||||
(funcall additional-pred v))))
|
||||
|
||||
(defun use-package-normalize-function (v)
|
||||
"Reduce functional constructions to one of two normal forms:
|
||||
sym
|
||||
#'(lambda () ...)"
|
||||
(pcase v
|
||||
((pred symbolp) v)
|
||||
(`(,(or `quote `function)
|
||||
,(and sym (pred symbolp))) sym)
|
||||
(`(lambda . ,_) v)
|
||||
(`(quote ,(and lam `(lambda . ,_))) lam)
|
||||
(`(function ,(and lam `(lambda . ,_))) lam)
|
||||
(_ v)))
|
||||
(cond ((symbolp v) v)
|
||||
((and (listp v)
|
||||
(memq (car v) '(quote function))
|
||||
(use-package-non-nil-symbolp (cadr v)))
|
||||
(cadr v))
|
||||
((and (consp v)
|
||||
(eq 'lambda (car v)))
|
||||
v)
|
||||
((and (listp v)
|
||||
(memq '(quote function) (car v))
|
||||
(eq 'lambda (car (cadr v))))
|
||||
(cadr v))
|
||||
(t v)))
|
||||
|
||||
(defun use-package-normalize-commands (args)
|
||||
"Map over ARGS of the form ((_ . F) ...).
|
||||
|
|
@ -928,7 +937,7 @@ representing symbols (that may need to be autloaded)."
|
|||
((not arg)
|
||||
(use-package-process-keywords name rest state))
|
||||
((eq arg t)
|
||||
`((let ((,context
|
||||
`((defvar ,context
|
||||
#'(lambda (keyword err)
|
||||
(let ((msg (format "%s/%s: %s" ',name keyword
|
||||
(error-message-string err))))
|
||||
|
|
@ -942,17 +951,17 @@ representing symbols (that may need to be autloaded)."
|
|||
(setq msg
|
||||
(concat msg
|
||||
" (see the *use-package* buffer)"))))
|
||||
(ignore (display-warning 'use-package msg :error))))))
|
||||
(ignore (display-warning 'use-package msg :error)))))
|
||||
,@(let ((use-package--hush-function
|
||||
(apply-partially #'use-package-hush context)))
|
||||
(funcall use-package--hush-function keyword
|
||||
(use-package-process-keywords name rest state))))))
|
||||
(use-package-process-keywords name rest state)))))
|
||||
((functionp arg)
|
||||
`((let ((,context ,arg))
|
||||
`((defvar ,context ,arg)
|
||||
,@(let ((use-package--hush-function
|
||||
(apply-partially #'use-package-hush context)))
|
||||
(funcall use-package--hush-function keyword
|
||||
(use-package-process-keywords name rest state))))))
|
||||
(use-package-process-keywords name rest state)))))
|
||||
(t
|
||||
(use-package-error "The :catch keyword expects 't' or a function")))))
|
||||
|
||||
|
|
@ -960,8 +969,9 @@ representing symbols (that may need to be autloaded)."
|
|||
|
||||
(defun use-package-handle-mode (name alist args rest state)
|
||||
"Handle keywords which add regexp/mode pairs to an alist."
|
||||
(cl-destructuring-bind (nargs . commands)
|
||||
(use-package-normalize-commands args)
|
||||
(let* ((result (use-package-normalize-commands args))
|
||||
(nargs (car result))
|
||||
(commands (cdr result)))
|
||||
(use-package-concat
|
||||
(use-package-process-keywords name
|
||||
(use-package-sort-keywords
|
||||
|
|
@ -1026,8 +1036,9 @@ representing symbols (that may need to be autloaded)."
|
|||
|
||||
(defun use-package-handler/:hook (name keyword args rest state)
|
||||
"Generate use-package custom keyword code."
|
||||
(cl-destructuring-bind (nargs . commands)
|
||||
(use-package-normalize-commands args)
|
||||
(let* ((result (use-package-normalize-commands args))
|
||||
(nargs (car result))
|
||||
(commands (cdr result)))
|
||||
(use-package-concat
|
||||
(use-package-process-keywords name
|
||||
(use-package-sort-keywords
|
||||
|
|
@ -1097,38 +1108,43 @@ representing symbols (that may need to be autloaded)."
|
|||
|
||||
(defun use-package-after-count-uses (features)
|
||||
"Count the number of time the body would appear in the result."
|
||||
(pcase features
|
||||
((and (pred use-package-non-nil-symbolp) feat)
|
||||
(cond ((use-package-non-nil-symbolp features)
|
||||
1)
|
||||
(`(,(or `:or `:any) . ,rest)
|
||||
((and (consp features)
|
||||
(memq (car features) '(:or :any)))
|
||||
(let ((num 0))
|
||||
(dolist (next rest)
|
||||
(cl-dolist (next (cdr features))
|
||||
(setq num (+ num (use-package-after-count-uses next))))
|
||||
num))
|
||||
(`(,(or `:and `:all) . ,rest)
|
||||
(apply #'max (mapcar #'use-package-after-count-uses rest)))
|
||||
(`(,feat . ,rest)
|
||||
(use-package-after-count-uses (cons :all (cons feat rest))))))
|
||||
((and (consp features)
|
||||
(memq (car features) '(:and :all)))
|
||||
(apply #'max (mapcar #'use-package-after-count-uses
|
||||
(cdr features))))
|
||||
((listp features)
|
||||
(use-package-after-count-uses (cons :all features)))))
|
||||
|
||||
(defun use-package-require-after-load (features body)
|
||||
"Generate `eval-after-load' statements to represents FEATURES.
|
||||
FEATURES is a list containing keywords `:and' and `:all', where
|
||||
no keyword implies `:all'."
|
||||
(pcase features
|
||||
((and (pred use-package-non-nil-symbolp) feat)
|
||||
`(eval-after-load ',feat
|
||||
(cond
|
||||
((use-package-non-nil-symbolp features)
|
||||
`(eval-after-load ',features
|
||||
,(if (member (car body) '(quote backquote \' \`))
|
||||
body
|
||||
(list 'quote body))))
|
||||
(`(,(or `:or `:any) . ,rest)
|
||||
((and (consp features)
|
||||
(memq (car features) '(:or :any)))
|
||||
(macroexp-progn
|
||||
(mapcar #'(lambda (x) (use-package-require-after-load x body)) rest)))
|
||||
(`(,(or `:and `:all) . ,rest)
|
||||
(dolist (next rest)
|
||||
(mapcar #'(lambda (x) (use-package-require-after-load x body))
|
||||
(cdr features))))
|
||||
((and (consp features)
|
||||
(memq (car features) '(:and :all)))
|
||||
(cl-dolist (next (cdr features))
|
||||
(setq body (use-package-require-after-load next body)))
|
||||
body)
|
||||
(`(,feat . ,rest)
|
||||
(use-package-require-after-load (cons :all (cons feat rest)) body))))
|
||||
((listp features)
|
||||
(use-package-require-after-load (cons :all features) body))))
|
||||
|
||||
(defun use-package-handler/:after (name keyword arg rest state)
|
||||
(let ((body (use-package-process-keywords name rest state))
|
||||
|
|
@ -1186,7 +1202,7 @@ no keyword implies `:all'."
|
|||
name-symbol)))
|
||||
(unless (listp arg)
|
||||
(use-package-error error-msg))
|
||||
(dolist (def arg arg)
|
||||
(cl-dolist (def arg arg)
|
||||
(unless (listp def)
|
||||
(use-package-error error-msg))
|
||||
(let ((face (nth 0 def))
|
||||
|
|
@ -1229,7 +1245,7 @@ no keyword implies `:all'."
|
|||
|
||||
(defun use-package-handler/:load (name keyword arg rest state)
|
||||
(let ((body (use-package-process-keywords name rest state)))
|
||||
(dolist (pkg arg)
|
||||
(cl-dolist (pkg arg)
|
||||
(setq body (use-package-require pkg nil body)))
|
||||
body))
|
||||
|
||||
|
|
|
|||
|
|
@ -138,14 +138,16 @@ manually updated package."
|
|||
(list t)
|
||||
(use-package-only-one (symbol-name keyword) args
|
||||
#'(lambda (label arg)
|
||||
(pcase arg
|
||||
((pred symbolp)
|
||||
(cond
|
||||
((symbolp arg)
|
||||
(list arg))
|
||||
(`(,(and pkg (pred symbolp))
|
||||
:pin ,(and repo (or (pred stringp)
|
||||
(pred symbolp))))
|
||||
(list (cons pkg repo)))
|
||||
(_
|
||||
((and (listp arg) (= 3 (length arg))
|
||||
(symbolp (nth 0 arg))
|
||||
(eq :pin (nth 1 arg))
|
||||
(or (stringp (nth 2 arg))
|
||||
(symbolp (nth 2 arg))))
|
||||
(list (cons (nth 0 arg) (nth 2 arg))))
|
||||
(t
|
||||
(use-package-error
|
||||
(concat ":ensure wants an optional package name "
|
||||
"(an unquoted symbol name), or (<symbol> :pin <string>)"))))))))
|
||||
|
|
|
|||
|
|
@ -994,12 +994,17 @@
|
|||
(ert-deftest use-package-test/:catch-1 ()
|
||||
(match-expansion
|
||||
(use-package foo :catch t)
|
||||
`(let
|
||||
((,_ #'(lambda (keyword err)
|
||||
(let ((msg (format "%s/%s: %s" 'foo keyword
|
||||
`(progn
|
||||
(defvar ,_
|
||||
#'(lambda
|
||||
(keyword err)
|
||||
(let
|
||||
((msg
|
||||
(format "%s/%s: %s" 'foo keyword
|
||||
(error-message-string err))))
|
||||
nil
|
||||
(ignore (display-warning 'use-package msg :error))))))
|
||||
(ignore
|
||||
(display-warning 'use-package msg :error)))))
|
||||
(condition-case-unless-debug err
|
||||
(require 'foo nil nil)
|
||||
(error
|
||||
|
|
@ -1013,8 +1018,8 @@
|
|||
(ert-deftest use-package-test/:catch-3 ()
|
||||
(match-expansion
|
||||
(use-package foo :catch (lambda (keyword error)))
|
||||
`(let
|
||||
((,_ (lambda (keyword error))))
|
||||
`(progn
|
||||
(defvar ,_ (lambda (keyword error)))
|
||||
(condition-case-unless-debug err
|
||||
(require 'foo nil nil)
|
||||
(error
|
||||
|
|
@ -1055,84 +1060,126 @@
|
|||
(ert-deftest use-package-test/:after-5 ()
|
||||
(match-expansion
|
||||
(use-package foo :after (:any bar quux))
|
||||
`(lexical-let ,_
|
||||
(lexical-let ,_
|
||||
`(progn
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_
|
||||
#'(lambda nil
|
||||
(if ,_ ,_
|
||||
(setq ,_ t)
|
||||
(setq ,_
|
||||
(require 'foo nil nil)))))
|
||||
(progn
|
||||
(eval-after-load 'bar
|
||||
`(funcall ,_))
|
||||
'(funcall ,_))
|
||||
(eval-after-load 'quux
|
||||
`(funcall ,_)))))))
|
||||
'(funcall ,_))))))
|
||||
|
||||
(ert-deftest use-package-test/:after-6 ()
|
||||
(match-expansion
|
||||
(use-package foo :after (:all (:any bar quux) bow))
|
||||
`(lexical-let ,_
|
||||
(lexical-let ,_
|
||||
`(progn
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_
|
||||
#'(lambda nil
|
||||
(if ,_ ,_
|
||||
(setq ,_ t)
|
||||
(setq ,_
|
||||
(require 'foo nil nil)))))
|
||||
(eval-after-load 'bow
|
||||
'(progn
|
||||
(eval-after-load 'bar
|
||||
`(funcall ,_))
|
||||
'(funcall ,_))
|
||||
(eval-after-load 'quux
|
||||
`(funcall ,_))))))))
|
||||
'(funcall ,_)))))))
|
||||
|
||||
(ert-deftest use-package-test/:after-7 ()
|
||||
(match-expansion
|
||||
(use-package foo :after (:any (:all bar quux) bow))
|
||||
`(lexical-let ,_
|
||||
(lexical-let ,_
|
||||
`(progn
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_
|
||||
#'(lambda nil
|
||||
(if ,_ ,_
|
||||
(setq ,_ t)
|
||||
(setq ,_
|
||||
(require 'foo nil nil)))))
|
||||
(progn
|
||||
(eval-after-load 'quux
|
||||
'(eval-after-load 'bar
|
||||
`(funcall ,_)))
|
||||
'(funcall ,_)))
|
||||
(eval-after-load 'bow
|
||||
`(funcall ,_)))))))
|
||||
'(funcall ,_))))))
|
||||
|
||||
(ert-deftest use-package-test/:after-8 ()
|
||||
(match-expansion
|
||||
(use-package foo :after (:all (:any bar quux) (:any bow baz)))
|
||||
`(lexical-let ,_
|
||||
(lexical-let ,_
|
||||
`(progn
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_
|
||||
#'(lambda nil
|
||||
(if ,_ ,_
|
||||
(setq ,_ t)
|
||||
(setq ,_
|
||||
(require 'foo nil nil)))))
|
||||
(progn
|
||||
(eval-after-load 'bow
|
||||
'(progn
|
||||
(eval-after-load 'bar
|
||||
`(funcall ,_))
|
||||
'(funcall ,_))
|
||||
(eval-after-load 'quux
|
||||
`(funcall ,_))))
|
||||
'(funcall ,_))))
|
||||
(eval-after-load 'baz
|
||||
'(progn
|
||||
(eval-after-load 'bar
|
||||
`(funcall ,_))
|
||||
'(funcall ,_))
|
||||
(eval-after-load 'quux
|
||||
`(funcall ,_)))))))))
|
||||
'(funcall ,_))))))))
|
||||
|
||||
(ert-deftest use-package-test/:after-9 ()
|
||||
(match-expansion
|
||||
(use-package foo :after (:any (:all bar quux) (:all bow baz)))
|
||||
`(lexical-let ,_
|
||||
(lexical-let ,_
|
||||
`(progn
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_
|
||||
#'(lambda nil
|
||||
(if ,_ ,_
|
||||
(setq ,_ t)
|
||||
(setq ,_
|
||||
(require 'foo nil nil)))))
|
||||
(progn
|
||||
(eval-after-load 'quux
|
||||
'(eval-after-load 'bar
|
||||
`(funcall ,_)))
|
||||
'(funcall ,_)))
|
||||
(eval-after-load 'baz
|
||||
'(eval-after-load 'bow
|
||||
`(funcall ,_))))))))
|
||||
'(funcall ,_)))))))
|
||||
|
||||
(ert-deftest use-package-test/:after-10 ()
|
||||
(match-expansion
|
||||
(use-package foo :after (:any (:all bar quux) (:any bow baz)))
|
||||
`(lexical-let ,_
|
||||
(lexical-let ,_
|
||||
`(progn
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_ nil)
|
||||
(defvar ,_
|
||||
#'(lambda nil
|
||||
(if ,_ ,_
|
||||
(setq ,_ t)
|
||||
(setq ,_
|
||||
(require 'foo nil nil)))))
|
||||
(progn
|
||||
(eval-after-load 'quux
|
||||
'(eval-after-load 'bar
|
||||
`(funcall ,_)))
|
||||
'(funcall ,_)))
|
||||
(progn
|
||||
(eval-after-load 'bow
|
||||
`(funcall ,_))
|
||||
'(funcall ,_))
|
||||
(eval-after-load 'baz
|
||||
`(funcall ,_))))))))
|
||||
'(funcall ,_)))))))
|
||||
|
||||
(ert-deftest use-package-test/:demand-1 ()
|
||||
(match-expansion
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue