mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 14:30:50 -08:00
Code Issues Projects Releases Wiki Activity

Avoid using pcase and many other macros in macro-expanded forms

Browse source 
This is related to https://github.com/jwiegley/use-package/issues/550
This commit is contained in:
John Wiegley 2017-12-05 11:10:16 -08:00
parent a090961f10
commit 0a628a2767
5 changed files with 263 additions and 193 deletions
Download patch file Download diff file Expand all files Collapse all files

22
lisp/use-package/bind-key.el
View file

@ -237,14 +237,20 @@ function symbol (unquoted)."
;; Process any initial keyword arguments ;; Process any initial keyword arguments
(let ((cont t)) (let ((cont t))
(while (and cont args) (while (and cont args)
(if (pcase (car args) (if (cond ((eq :map (car args))
(`:map (setq map (cadr args))) (setq map (cadr args)))
(`:prefix-docstring (setq doc (cadr args))) ((eq :prefix-docstring (car args))
(`:prefix-map (setq prefix-map (cadr args))) (setq doc (cadr args)))
(`:prefix (setq prefix (cadr args))) ((eq :prefix-map (car args))
(`:filter (setq filter (cadr args)) t) (setq prefix-map (cadr args)))
(`:menu-name (setq menu-name (cadr args))) ((eq :prefix (car args))
(`:package (setq pkg (cadr 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 args (cddr args))
(setq cont nil)))) (setq cont nil))))

11
lisp/use-package/use-package-bind-key.el
View file

@ -74,10 +74,8 @@ deferred until the prefix key sequence is pressed."
(concat label " a (<string or vector> . <symbol, string or function>)" (concat label " a (<string or vector> . <symbol, string or function>)"
" or list of these"))) " or list of these")))
(use-package-normalize-pairs (use-package-normalize-pairs
#'(lambda (k) #'(lambda (k) (cond ((stringp k) t)
(pcase k ((vectorp k) t)))
((pred stringp) t)
((pred vectorp) t)))
#'(lambda (v) (use-package-recognize-function v t #'stringp)) #'(lambda (v) (use-package-recognize-function v t #'stringp))
name label arg)))) name label arg))))
@ -91,8 +89,9 @@ deferred until the prefix key sequence is pressed."
;;;###autoload ;;;###autoload
(defun use-package-handler/:bind (defun use-package-handler/:bind
(name keyword args rest state &optional bind-macro) (name keyword args rest state &optional bind-macro)
(cl-destructuring-bind (nargs . commands) (let* ((result (use-package-normalize-commands args))
(use-package-normalize-commands args) (nargs (car result))
(commands (cdr result)))
(use-package-concat (use-package-concat
(use-package-process-keywords name (use-package-process-keywords name
(use-package-sort-keywords (use-package-sort-keywords

222
lisp/use-package/use-package-core.el
View file

@ -429,7 +429,7 @@ This is in contrast to merely setting it to 0."
(defun use-package-split-list (pred xs) (defun use-package-split-list (pred xs)
(let ((ys (list nil)) (zs (list nil)) flip) (let ((ys (list nil)) (zs (list nil)) flip)
(dolist (x xs) (cl-dolist (x xs)
(if flip (if flip
(nconc zs (list x)) (nconc zs (list x))
(if (funcall pred 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) (defun use-package-keyword-index (keyword)
(loop named outer (cl-loop named outer
with index = 0 with index = 0
for k in use-package-keywords do for k in use-package-keywords do
(if (eq k keyword) (if (eq k keyword)
(return-from outer index)) (cl-return-from outer index))
(incf index))) (cl-incf index)))
(defun use-package-normalize-plist (name input &optional plist merge-function) (defun use-package-normalize-plist (name input &optional plist merge-function)
"Given a pseudo-plist, normalize it to a regular plist. "Given a pseudo-plist, normalize it to a regular plist.
@ -492,11 +492,10 @@ extending any keys already present."
args) args)
(defun use-package-merge-keys (key new old) (defun use-package-merge-keys (key new old)
(pcase key (cond ((eq :if key) `(and ,new ,old))
(`:if `(and ,new ,old)) ((eq :after key) `(:all ,new ,old))
(`:after `(:all ,new ,old)) ((eq :defer key) old)
(`:defer old) (t (append new old))))
(_ (append new old))))
(defun use-package-sort-keywords (plist) (defun use-package-sort-keywords (plist)
(let (plist-grouped) (let (plist-grouped)
@ -505,11 +504,12 @@ extending any keys already present."
plist-grouped) plist-grouped)
(setq plist (cddr plist))) (setq plist (cddr plist)))
(let (result) (let (result)
(dolist (x (cl-dolist
(nreverse (x
(sort plist-grouped (nreverse
#'(lambda (l r) (< (use-package-keyword-index (car l)) (sort plist-grouped
(use-package-keyword-index (car r))))))) #'(lambda (l r) (< (use-package-keyword-index (car l))
(use-package-keyword-index (car r)))))))
(setq result (cons (car x) (cons (cdr x) result)))) (setq result (cons (car x) (cons (cdr x) result))))
result))) result)))
@ -525,10 +525,11 @@ extending any keys already present."
#'use-package-merge-keys)) #'use-package-merge-keys))
;; Add default values for keywords not specified, when applicable. ;; Add default values for keywords not specified, when applicable.
(dolist (spec use-package-defaults) (cl-dolist (spec use-package-defaults)
(when (pcase (nth 2 spec) (when (let ((func (nth 2 spec)))
((and func (pred functionp)) (funcall func args)) (if (and func (functionp func))
(sexp (eval sexp))) (funcall func args)
(eval func)))
(setq args (use-package-plist-maybe-put (setq args (use-package-plist-maybe-put
args (nth 0 spec) (eval (nth 1 spec)))))) args (nth 0 spec) (eval (nth 1 spec))))))
@ -639,13 +640,14 @@ no more than once."
(let ((loaded (cl-gensym "use-package--loaded")) (let ((loaded (cl-gensym "use-package--loaded"))
(result (cl-gensym "use-package--result")) (result (cl-gensym "use-package--result"))
(next (cl-gensym "use-package--next"))) (next (cl-gensym "use-package--next")))
`((lexical-let (,loaded ,result) `((defvar ,loaded nil)
(lexical-let ((,next (lambda () (defvar ,result nil)
(if ,loaded (defvar ,next #'(lambda ()
,result (if ,loaded
(setq ,loaded t) ,result
(setq ,result ,arg))))) (setq ,loaded t)
,(funcall f ``(funcall ,,next))))))) (setq ,result ,arg))))
,(funcall f `(funcall ,next)))))
(defsubst use-package-normalize-value (label arg) (defsubst use-package-normalize-value (label arg)
"Normalize a value." "Normalize a value."
@ -718,7 +720,9 @@ no more than once."
(use-package-error (concat label " wants a sexp or list of sexps"))) (use-package-error (concat label " wants a sexp or list of sexps")))
(mapcar #'(lambda (form) (mapcar #'(lambda (form)
(if (and (consp 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) (macroexpand form)
form)) args)) form)) args))
@ -763,28 +767,33 @@ If RECURSED is non-nil, recurse into sublists."
(quote (lambda () ...)) (quote (lambda () ...))
#'(lambda () ...) #'(lambda () ...)
(function (lambda () ...))" (function (lambda () ...))"
(pcase v (or (if binding
((and x (guard (if binding (symbolp v)
(symbolp x) (use-package-non-nil-symbolp v))
(use-package-non-nil-symbolp x)))) t) (and (listp v)
(`(,(or `quote `function) (memq (car v) '(quote function))
,(pred use-package-non-nil-symbolp)) t) (use-package-non-nil-symbolp (cadr v)))
((and x (guard (if binding (commandp x) (functionp x)))) t) (if binding (commandp v) (functionp v))
(_ (and additional-pred (and additional-pred
(funcall additional-pred v))))) (funcall additional-pred v))))
(defun use-package-normalize-function (v) (defun use-package-normalize-function (v)
"Reduce functional constructions to one of two normal forms: "Reduce functional constructions to one of two normal forms:
sym sym
#'(lambda () ...)" #'(lambda () ...)"
(pcase v (cond ((symbolp v) v)
((pred symbolp) v) ((and (listp v)
(`(,(or `quote `function) (memq (car v) '(quote function))
,(and sym (pred symbolp))) sym) (use-package-non-nil-symbolp (cadr v)))
(`(lambda . ,_) v) (cadr v))
(`(quote ,(and lam `(lambda . ,_))) lam) ((and (consp v)
(`(function ,(and lam `(lambda . ,_))) lam) (eq 'lambda (car v)))
(_ 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) (defun use-package-normalize-commands (args)
"Map over ARGS of the form ((_ . F) ...). "Map over ARGS of the form ((_ . F) ...).
@ -928,31 +937,31 @@ representing symbols (that may need to be autloaded)."
((not arg) ((not arg)
(use-package-process-keywords name rest state)) (use-package-process-keywords name rest state))
((eq arg t) ((eq arg t)
`((let ((,context `((defvar ,context
#'(lambda (keyword err) #'(lambda (keyword err)
(let ((msg (format "%s/%s: %s" ',name keyword (let ((msg (format "%s/%s: %s" ',name keyword
(error-message-string err)))) (error-message-string err))))
,(when (eq use-package-verbose 'debug) ,(when (eq use-package-verbose 'debug)
`(progn `(progn
(with-current-buffer (with-current-buffer
(get-buffer-create "*use-package*") (get-buffer-create "*use-package*")
(goto-char (point-max)) (goto-char (point-max))
(insert "-----\n" msg ,use-package--form) (insert "-----\n" msg ,use-package--form)
(emacs-lisp-mode)) (emacs-lisp-mode))
(setq msg (setq msg
(concat msg (concat msg
" (see the *use-package* buffer)")))) " (see the *use-package* buffer)"))))
(ignore (display-warning 'use-package msg :error)))))) (ignore (display-warning 'use-package msg :error)))))
,@(let ((use-package--hush-function ,@(let ((use-package--hush-function
(apply-partially #'use-package-hush context))) (apply-partially #'use-package-hush context)))
(funcall use-package--hush-function keyword (funcall use-package--hush-function keyword
(use-package-process-keywords name rest state)))))) (use-package-process-keywords name rest state)))))
((functionp arg) ((functionp arg)
`((let ((,context ,arg)) `((defvar ,context ,arg)
,@(let ((use-package--hush-function ,@(let ((use-package--hush-function
(apply-partially #'use-package-hush context))) (apply-partially #'use-package-hush context)))
(funcall use-package--hush-function keyword (funcall use-package--hush-function keyword
(use-package-process-keywords name rest state)))))) (use-package-process-keywords name rest state)))))
(t (t
(use-package-error "The :catch keyword expects 't' or a function"))))) (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) (defun use-package-handle-mode (name alist args rest state)
"Handle keywords which add regexp/mode pairs to an alist." "Handle keywords which add regexp/mode pairs to an alist."
(cl-destructuring-bind (nargs . commands) (let* ((result (use-package-normalize-commands args))
(use-package-normalize-commands args) (nargs (car result))
(commands (cdr result)))
(use-package-concat (use-package-concat
(use-package-process-keywords name (use-package-process-keywords name
(use-package-sort-keywords (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) (defun use-package-handler/:hook (name keyword args rest state)
"Generate use-package custom keyword code." "Generate use-package custom keyword code."
(cl-destructuring-bind (nargs . commands) (let* ((result (use-package-normalize-commands args))
(use-package-normalize-commands args) (nargs (car result))
(commands (cdr result)))
(use-package-concat (use-package-concat
(use-package-process-keywords name (use-package-process-keywords name
(use-package-sort-keywords (use-package-sort-keywords
@ -1097,38 +1108,43 @@ representing symbols (that may need to be autloaded)."
(defun use-package-after-count-uses (features) (defun use-package-after-count-uses (features)
"Count the number of time the body would appear in the result." "Count the number of time the body would appear in the result."
(pcase features (cond ((use-package-non-nil-symbolp features)
((and (pred use-package-non-nil-symbolp) feat) 1)
1) ((and (consp features)
(`(,(or `:or `:any) . ,rest) (memq (car features) '(:or :any)))
(let ((num 0)) (let ((num 0))
(dolist (next rest) (cl-dolist (next (cdr features))
(setq num (+ num (use-package-after-count-uses next)))) (setq num (+ num (use-package-after-count-uses next))))
num)) num))
(`(,(or `:and `:all) . ,rest) ((and (consp features)
(apply #'max (mapcar #'use-package-after-count-uses rest))) (memq (car features) '(:and :all)))
(`(,feat . ,rest) (apply #'max (mapcar #'use-package-after-count-uses
(use-package-after-count-uses (cons :all (cons feat rest)))))) (cdr features))))
((listp features)
(use-package-after-count-uses (cons :all features)))))
(defun use-package-require-after-load (features body) (defun use-package-require-after-load (features body)
"Generate `eval-after-load' statements to represents FEATURES. "Generate `eval-after-load' statements to represents FEATURES.
FEATURES is a list containing keywords `:and' and `:all', where FEATURES is a list containing keywords `:and' and `:all', where
no keyword implies `:all'." no keyword implies `:all'."
(pcase features (cond
((and (pred use-package-non-nil-symbolp) feat) ((use-package-non-nil-symbolp features)
`(eval-after-load ',feat `(eval-after-load ',features
,(if (member (car body) '(quote backquote \' \`)) ,(if (member (car body) '(quote backquote \' \`))
body body
(list 'quote body)))) (list 'quote body))))
(`(,(or `:or `:any) . ,rest) ((and (consp features)
(macroexp-progn (memq (car features) '(:or :any)))
(mapcar #'(lambda (x) (use-package-require-after-load x body)) rest))) (macroexp-progn
(`(,(or `:and `:all) . ,rest) (mapcar #'(lambda (x) (use-package-require-after-load x body))
(dolist (next rest) (cdr features))))
(setq body (use-package-require-after-load next body))) ((and (consp features)
body) (memq (car features) '(:and :all)))
(`(,feat . ,rest) (cl-dolist (next (cdr features))
(use-package-require-after-load (cons :all (cons feat rest)) body)))) (setq body (use-package-require-after-load next body)))
body)
((listp features)
(use-package-require-after-load (cons :all features) body))))
(defun use-package-handler/:after (name keyword arg rest state) (defun use-package-handler/:after (name keyword arg rest state)
(let ((body (use-package-process-keywords name rest state)) (let ((body (use-package-process-keywords name rest state))
@ -1186,7 +1202,7 @@ no keyword implies `:all'."
name-symbol))) name-symbol)))
(unless (listp arg) (unless (listp arg)
(use-package-error error-msg)) (use-package-error error-msg))
(dolist (def arg arg) (cl-dolist (def arg arg)
(unless (listp def) (unless (listp def)
(use-package-error error-msg)) (use-package-error error-msg))
(let ((face (nth 0 def)) (let ((face (nth 0 def))
@ -1229,7 +1245,7 @@ no keyword implies `:all'."
(defun use-package-handler/:load (name keyword arg rest state) (defun use-package-handler/:load (name keyword arg rest state)
(let ((body (use-package-process-keywords name 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))) (setq body (use-package-require pkg nil body)))
body)) body))

24
lisp/use-package/use-package-ensure.el
View file

@ -138,17 +138,19 @@ manually updated package."
(list t) (list t)
(use-package-only-one (symbol-name keyword) args (use-package-only-one (symbol-name keyword) args
#'(lambda (label arg) #'(lambda (label arg)
(pcase arg (cond
((pred symbolp) ((symbolp arg)
(list arg)) (list arg))
(`(,(and pkg (pred symbolp)) ((and (listp arg) (= 3 (length arg))
:pin ,(and repo (or (pred stringp) (symbolp (nth 0 arg))
(pred symbolp)))) (eq :pin (nth 1 arg))
(list (cons pkg repo))) (or (stringp (nth 2 arg))
(_ (symbolp (nth 2 arg))))
(use-package-error (list (cons (nth 0 arg) (nth 2 arg))))
(concat ":ensure wants an optional package name " (t
"(an unquoted symbol name), or (<symbol> :pin <string>)")))))))) (use-package-error
(concat ":ensure wants an optional package name "
"(an unquoted symbol name), or (<symbol> :pin <string>)"))))))))
(defun use-package-ensure-elpa (name args state &optional no-refresh) (defun use-package-ensure-elpa (name args state &optional no-refresh)
(dolist (ensure args) (dolist (ensure args)

177
test/lisp/use-package/use-package-tests.el
View file

@ -994,12 +994,17 @@
(ert-deftest use-package-test/:catch-1 () (ert-deftest use-package-test/:catch-1 ()
(match-expansion (match-expansion
(use-package foo :catch t) (use-package foo :catch t)
`(let `(progn
((,_ #'(lambda (keyword err) (defvar ,_
(let ((msg (format "%s/%s: %s" 'foo keyword #'(lambda
(error-message-string err)))) (keyword err)
nil (let
(ignore (display-warning 'use-package msg :error)))))) ((msg
(format "%s/%s: %s" 'foo keyword
(error-message-string err))))
nil
(ignore
(display-warning 'use-package msg :error)))))
(condition-case-unless-debug err (condition-case-unless-debug err
(require 'foo nil nil) (require 'foo nil nil)
(error (error
@ -1013,8 +1018,8 @@
(ert-deftest use-package-test/:catch-3 () (ert-deftest use-package-test/:catch-3 ()
(match-expansion (match-expansion
(use-package foo :catch (lambda (keyword error))) (use-package foo :catch (lambda (keyword error)))
`(let `(progn
((,_ (lambda (keyword error)))) (defvar ,_ (lambda (keyword error)))
(condition-case-unless-debug err (condition-case-unless-debug err
(require 'foo nil nil) (require 'foo nil nil)
(error (error
@ -1055,84 +1060,126 @@
(ert-deftest use-package-test/:after-5 () (ert-deftest use-package-test/:after-5 ()
(match-expansion (match-expansion
(use-package foo :after (:any bar quux)) (use-package foo :after (:any bar quux))
`(lexical-let ,_ `(progn
(lexical-let ,_ (defvar ,_ nil)
(progn (defvar ,_ nil)
(eval-after-load 'bar (defvar ,_
`(funcall ,_)) #'(lambda nil
(eval-after-load 'quux (if ,_ ,_
`(funcall ,_))))))) (setq ,_ t)
(setq ,_
(require 'foo nil nil)))))
(progn
(eval-after-load 'bar
'(funcall ,_))
(eval-after-load 'quux
'(funcall ,_))))))
(ert-deftest use-package-test/:after-6 () (ert-deftest use-package-test/:after-6 ()
(match-expansion (match-expansion
(use-package foo :after (:all (:any bar quux) bow)) (use-package foo :after (:all (:any bar quux) bow))
`(lexical-let ,_ `(progn
(lexical-let ,_ (defvar ,_ nil)
(eval-after-load 'bow (defvar ,_ nil)
'(progn (defvar ,_
(eval-after-load 'bar #'(lambda nil
`(funcall ,_)) (if ,_ ,_
(eval-after-load 'quux (setq ,_ t)
`(funcall ,_)))))))) (setq ,_
(require 'foo nil nil)))))
(eval-after-load 'bow
'(progn
(eval-after-load 'bar
'(funcall ,_))
(eval-after-load 'quux
'(funcall ,_)))))))
(ert-deftest use-package-test/:after-7 () (ert-deftest use-package-test/:after-7 ()
(match-expansion (match-expansion
(use-package foo :after (:any (:all bar quux) bow)) (use-package foo :after (:any (:all bar quux) bow))
`(lexical-let ,_ `(progn
(lexical-let ,_ (defvar ,_ nil)
(progn (defvar ,_ nil)
(eval-after-load 'quux (defvar ,_
'(eval-after-load 'bar #'(lambda nil
`(funcall ,_))) (if ,_ ,_
(eval-after-load 'bow (setq ,_ t)
`(funcall ,_))))))) (setq ,_
(require 'foo nil nil)))))
(progn
(eval-after-load 'quux
'(eval-after-load 'bar
'(funcall ,_)))
(eval-after-load 'bow
'(funcall ,_))))))
(ert-deftest use-package-test/:after-8 () (ert-deftest use-package-test/:after-8 ()
(match-expansion (match-expansion
(use-package foo :after (:all (:any bar quux) (:any bow baz))) (use-package foo :after (:all (:any bar quux) (:any bow baz)))
`(lexical-let ,_ `(progn
(lexical-let ,_ (defvar ,_ nil)
(progn (defvar ,_ nil)
(eval-after-load 'bow (defvar ,_
'(progn #'(lambda nil
(eval-after-load 'bar (if ,_ ,_
`(funcall ,_)) (setq ,_ t)
(eval-after-load 'quux (setq ,_
`(funcall ,_)))) (require 'foo nil nil)))))
(eval-after-load 'baz (progn
'(progn (eval-after-load 'bow
(eval-after-load 'bar '(progn
`(funcall ,_)) (eval-after-load 'bar
(eval-after-load 'quux '(funcall ,_))
`(funcall ,_))))))))) (eval-after-load 'quux
'(funcall ,_))))
(eval-after-load 'baz
'(progn
(eval-after-load 'bar
'(funcall ,_))
(eval-after-load 'quux
'(funcall ,_))))))))
(ert-deftest use-package-test/:after-9 () (ert-deftest use-package-test/:after-9 ()
(match-expansion (match-expansion
(use-package foo :after (:any (:all bar quux) (:all bow baz))) (use-package foo :after (:any (:all bar quux) (:all bow baz)))
`(lexical-let ,_ `(progn
(lexical-let ,_ (defvar ,_ nil)
(progn (defvar ,_ nil)
(eval-after-load 'quux (defvar ,_
'(eval-after-load 'bar #'(lambda nil
`(funcall ,_))) (if ,_ ,_
(eval-after-load 'baz (setq ,_ t)
'(eval-after-load 'bow (setq ,_
`(funcall ,_)))))))) (require 'foo nil nil)))))
(progn
(eval-after-load 'quux
'(eval-after-load 'bar
'(funcall ,_)))
(eval-after-load 'baz
'(eval-after-load 'bow
'(funcall ,_)))))))
(ert-deftest use-package-test/:after-10 () (ert-deftest use-package-test/:after-10 ()
(match-expansion (match-expansion
(use-package foo :after (:any (:all bar quux) (:any bow baz))) (use-package foo :after (:any (:all bar quux) (:any bow baz)))
`(lexical-let ,_ `(progn
(lexical-let ,_ (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 ,_)))
(progn (progn
(eval-after-load 'quux (eval-after-load 'bow
'(eval-after-load 'bar '(funcall ,_))
`(funcall ,_))) (eval-after-load 'baz
(progn '(funcall ,_)))))))
(eval-after-load 'bow
`(funcall ,_))
(eval-after-load 'baz
`(funcall ,_))))))))
(ert-deftest use-package-test/:demand-1 () (ert-deftest use-package-test/:demand-1 ()
(match-expansion (match-expansion