-;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
+;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
;; - along these lines, provide patterns to match CL structs.
;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound.
-;; - provide a way to fallthrough to subsequent cases.
+;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
+;; this :-()
;; - try and be more clever to reduce the size of the decision tree, and
;; to reduce the number of leaves that need to be turned into function:
;; - first, do the tests shared by all remaining branches (it will have
-;; to be performed anyway, so better so it first so it's shared).
+;; to be performed anyway, so better do it first so it's shared).
;; - then choose the test that discriminates more (?).
+;; - provide Agda's `with' (along with its `...' companion).
+;; - implement (not UPAT). This might require a significant redesign.
;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
;; generate a lex-style DFA to decide whether to run E1 or E2.
;;; Code:
+(require 'macroexp)
+
;; Macro-expansion of pcase is reasonably fast, so it's not a problem
;; when byte-compiling a file, but when interpreting the code, if the pcase
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
;; memoize previous macro expansions to try and avoid recomputing them
;; over and over again.
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
+;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
+;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
(defconst pcase--dontcare-upats '(t _ dontcare))
+(def-edebug-spec
+ pcase-UPAT
+ (&or symbolp
+ ("or" &rest pcase-UPAT)
+ ("and" &rest pcase-UPAT)
+ ("`" pcase-QPAT)
+ ("guard" form)
+ ("let" pcase-UPAT form)
+ ("pred"
+ &or lambda-expr
+ ;; Punt on macros/special forms.
+ (functionp &rest form)
+ sexp)
+ sexp))
+
+(def-edebug-spec
+ pcase-QPAT
+ (&or ("," pcase-UPAT)
+ (pcase-QPAT . pcase-QPAT)
+ sexp))
+
;;;###autoload
(defmacro pcase (exp &rest cases)
"Perform ML-style pattern matching on EXP.
E.g. you can match pairs where the cdr is larger than the car with a pattern
like `(,a . ,(pred (< a))) or, with more checks:
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
- (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
+ (declare (indent 1) (debug (form &rest (pcase-UPAT body))))
;; We want to use a weak hash table as a cache, but the key will unavoidably
;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
;; we're called so it'll be immediately GC'd. So we use (car cases) as key
(if (and (equal exp (car data)) (equal cases (cadr data)))
;; We have the right expansion.
(cddr data)
+ ;; (when (gethash (car cases) pcase--memoize-1)
+ ;; (message "pcase-memoize failed because of weak key!!"))
+ ;; (when (gethash (car cases) pcase--memoize-2)
+ ;; (message "pcase-memoize failed because of eq test on %S"
+ ;; (car cases)))
(when data
(message "pcase-memoize: equal first branch, yet different"))
(let ((expansion (pcase--expand exp cases)))
- (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
+ (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
+ ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
+ ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
expansion))))
+(defun pcase--let* (bindings body)
+ (cond
+ ((null bindings) (macroexp-progn body))
+ ((pcase--trivial-upat-p (caar bindings))
+ (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
+ (t
+ (let ((binding (pop bindings)))
+ (pcase--expand
+ (cadr binding)
+ `((,(car binding) ,(pcase--let* bindings body))
+ ;; We can either signal an error here, or just use `dontcare' which
+ ;; generates more efficient code. In practice, if we use `dontcare'
+ ;; we will still often get an error and the few cases where we don't
+ ;; do not matter that much, so it's a better choice.
+ (dontcare nil)))))))
+
;;;###autoload
(defmacro pcase-let* (bindings &rest body)
"Like `let*' but where you can use `pcase' patterns for bindings.
BODY should be an expression, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
- (declare (indent 1) (debug let))
- (cond
- ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
- ((pcase--trivial-upat-p (caar bindings))
- `(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
- (t
- `(pcase ,(cadr (car bindings))
- (,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
- ;; We can either signal an error here, or just use `dontcare' which
- ;; generates more efficient code. In practice, if we use `dontcare' we
- ;; will still often get an error and the few cases where we don't do not
- ;; matter that much, so it's a better choice.
- (dontcare nil)))))
+ (declare (indent 1)
+ (debug ((&rest (pcase-UPAT &optional form)) body)))
+ (let ((cached (gethash bindings pcase--memoize)))
+ ;; cached = (BODY . EXPANSION)
+ (if (equal (car cached) body)
+ (cdr cached)
+ (let ((expansion (pcase--let* bindings body)))
+ (puthash bindings (cons body expansion) pcase--memoize)
+ expansion))))
;;;###autoload
(defmacro pcase-let (bindings &rest body)
"Like `let' but where you can use `pcase' patterns for bindings.
BODY should be a list of expressions, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
- (declare (indent 1) (debug let))
+ (declare (indent 1) (debug pcase-let*))
(if (null (cdr bindings))
`(pcase-let* ,bindings ,@body)
(let ((matches '()))
`(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
(defmacro pcase-dolist (spec &rest body)
+ (declare (indent 1) (debug ((pcase-UPAT form) body)))
(if (pcase--trivial-upat-p (car spec))
`(dolist ,spec ,@body)
(let ((tmpvar (make-symbol "x")))
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
- (let* ((defs (if (symbolp exp) '()
- (let ((sym (make-symbol "x")))
- (prog1 `((,sym ,exp)) (setq exp sym)))))
- (seen '())
- (codegen
- (lambda (code vars)
- (let ((prev (assq code seen)))
- (if (not prev)
- (let ((res (pcase-codegen code vars)))
- (push (list code vars res) seen)
- res)
- ;; Since we use a tree-based pattern matching
- ;; technique, the leaves (the places that contain the
- ;; code to run once a pattern is matched) can get
- ;; copied a very large number of times, so to avoid
- ;; code explosion, we need to keep track of how many
- ;; times we've used each leaf and move it
- ;; to a separate function if that number is too high.
- ;;
- ;; We've already used this branch. So it is shared.
- (let* ((code (car prev)) (cdrprev (cdr prev))
- (prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
- (res (car cddrprev)))
- (unless (symbolp res)
- ;; This is the first repeat, so we have to move
- ;; the branch to a separate function.
- (let ((bsym
- (make-symbol (format "pcase-%d" (length defs)))))
- (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
- (setcar res 'funcall)
- (setcdr res (cons bsym (mapcar #'cdr prevvars)))
- (setcar (cddr prev) bsym)
- (setq res bsym)))
- (setq vars (copy-sequence vars))
- (let ((args (mapcar (lambda (pa)
- (let ((v (assq (car pa) vars)))
- (setq vars (delq v vars))
- (cdr v)))
- prevvars)))
- (when vars ;New additional vars.
- (error "The vars %s are only bound in some paths"
- (mapcar #'car vars)))
- `(funcall ,res ,@args)))))))
- (main
- (pcase--u
- (mapcar (lambda (case)
- `((match ,exp . ,(car case))
- ,(apply-partially
- (if (pcase--small-branch-p (cdr case))
- ;; Don't bother sharing multiple
- ;; occurrences of this leaf since it's small.
- #'pcase-codegen codegen)
- (cdr case))))
- cases))))
- (if (null defs) main
- `(let ,defs ,main))))
+ (macroexp-let2 macroexp-copyable-p val exp
+ (let* ((defs ())
+ (seen '())
+ (codegen
+ (lambda (code vars)
+ (let ((prev (assq code seen)))
+ (if (not prev)
+ (let ((res (pcase-codegen code vars)))
+ (push (list code vars res) seen)
+ res)
+ ;; Since we use a tree-based pattern matching
+ ;; technique, the leaves (the places that contain the
+ ;; code to run once a pattern is matched) can get
+ ;; copied a very large number of times, so to avoid
+ ;; code explosion, we need to keep track of how many
+ ;; times we've used each leaf and move it
+ ;; to a separate function if that number is too high.
+ ;;
+ ;; We've already used this branch. So it is shared.
+ (let* ((code (car prev)) (cdrprev (cdr prev))
+ (prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
+ (res (car cddrprev)))
+ (unless (symbolp res)
+ ;; This is the first repeat, so we have to move
+ ;; the branch to a separate function.
+ (let ((bsym
+ (make-symbol (format "pcase-%d" (length defs)))))
+ (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code))
+ defs)
+ (setcar res 'funcall)
+ (setcdr res (cons bsym (mapcar #'cdr prevvars)))
+ (setcar (cddr prev) bsym)
+ (setq res bsym)))
+ (setq vars (copy-sequence vars))
+ (let ((args (mapcar (lambda (pa)
+ (let ((v (assq (car pa) vars)))
+ (setq vars (delq v vars))
+ (cdr v)))
+ prevvars)))
+ ;; If some of `vars' were not found in `prevvars', that's
+ ;; OK it just means those vars aren't present in all
+ ;; branches, so they can be used within the pattern
+ ;; (e.g. by a `guard/let/pred') but not in the branch.
+ ;; FIXME: But if some of `prevvars' are not in `vars' we
+ ;; should remove them from `prevvars'!
+ `(funcall ,res ,@args)))))))
+ (used-cases ())
+ (main
+ (pcase--u
+ (mapcar (lambda (case)
+ `((match ,val . ,(car case))
+ ,(lambda (vars)
+ (unless (memq case used-cases)
+ ;; Keep track of the cases that are used.
+ (push case used-cases))
+ (funcall
+ (if (pcase--small-branch-p (cdr case))
+ ;; Don't bother sharing multiple
+ ;; occurrences of this leaf since it's small.
+ #'pcase-codegen codegen)
+ (cdr case)
+ vars))))
+ cases))))
+ (dolist (case cases)
+ (unless (or (memq case used-cases) (eq (car case) 'dontcare))
+ (message "Redundant pcase pattern: %S" (car case))))
+ (macroexp-let* defs main))))
(defun pcase-codegen (code vars)
+ ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
+ ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
+ ;; codegen from later metamorphosing this let into a funcall.
`(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
,@code))
(cond
((eq else :pcase--dontcare) then)
((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
- ((eq (car-safe else) 'if)
- (if (equal test (nth 1 else))
- ;; Doing a test a second time: get rid of the redundancy.
- ;; FIXME: ideally, this should never happen because the pcase--split-*
- ;; funs should have eliminated such things, but pcase--split-member
- ;; is imprecise, so in practice it can happen occasionally.
- `(if ,test ,then ,@(nthcdr 3 else))
- `(cond (,test ,then)
- (,(nth 1 else) ,(nth 2 else))
- (t ,@(nthcdr 3 else)))))
- ((eq (car-safe else) 'cond)
- `(cond (,test ,then)
- ;; Doing a test a second time: get rid of the redundancy, as above.
- ,@(remove (assoc test else) (cdr else))))
- ;; Invert the test if that lets us reduce the depth of the tree.
- ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
- (t `(if ,test ,then ,else))))
+ (t (macroexp-if test then else))))
(defun pcase--upat (qpattern)
(cond
(defun pcase--split-pred (upat pat)
;; FIXME: For predicates like (pred (> a)), two such predicates may
;; actually refer to different variables `a'.
- (cond
- ((equal upat pat) (cons :pcase--succeed :pcase--fail))
- ((and (eq 'pred (car upat))
- (eq 'pred (car-safe pat))
- (or (member (cons (cadr upat) (cadr pat))
- pcase-mutually-exclusive-predicates)
- (member (cons (cadr pat) (cadr upat))
- pcase-mutually-exclusive-predicates)))
- (cons :pcase--fail nil))
- ;; ((and (eq 'pred (car upat))
- ;; (eq '\` (car-safe pat))
- ;; (symbolp (cadr upat))
- ;; (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
- ;; (get (cadr upat) 'side-effect-free)
- ;; (progn (message "Trying predicate %S" (cadr upat))
- ;; (ignore-errors
- ;; (funcall (cadr upat) (cadr pat)))))
- ;; (message "Simplify pred %S against %S" upat pat)
- ;; (cons nil :pcase--fail))
- ))
+ (let (test)
+ (cond
+ ((equal upat pat) (cons :pcase--succeed :pcase--fail))
+ ((and (eq 'pred (car upat))
+ (eq 'pred (car-safe pat))
+ (or (member (cons (cadr upat) (cadr pat))
+ pcase-mutually-exclusive-predicates)
+ (member (cons (cadr pat) (cadr upat))
+ pcase-mutually-exclusive-predicates)))
+ (cons :pcase--fail nil))
+ ((and (eq 'pred (car upat))
+ (eq '\` (car-safe pat))
+ (symbolp (cadr upat))
+ (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
+ (get (cadr upat) 'side-effect-free)
+ (ignore-errors
+ (setq test (list (funcall (cadr upat) (cadr pat))))))
+ (if (car test)
+ (cons nil :pcase--fail)
+ (cons :pcase--fail nil))))))
(defun pcase--fgrep (vars sexp)
"Check which of the symbols VARS appear in SEXP."
(if (eq (car upat) 'pred) (put sym 'pcase-used t))
(let* ((splitrest
(pcase--split-rest
- sym (apply-partially #'pcase--split-pred upat) rest))
+ sym (lambda (pat) (pcase--split-pred upat pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
(let ((newsym (make-symbol "x")))
(push (list newsym sym) env)
(setq sym newsym)))
- (if (functionp exp) `(,exp ,sym)
+ (if (functionp exp)
+ `(funcall #',exp ,sym)
`(,@exp ,sym)))))
(if (null vs)
call
;; A upat of the form (let VAR EXP).
;; (pcase--u1 matches code
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
- (let* ((exp
- (let* ((exp (nth 2 upat))
- (found (assq exp vars)))
- (if found (cdr found)
- (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
- (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
- vs)))
- (if env `(let* ,env ,exp) exp)))))
- (sym (if (symbolp exp) exp (make-symbol "x")))
- (body
- (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
- code vars rest)))
- (if (eq sym exp)
- body
- `(let* ((,sym ,exp)) ,body))))
+ (macroexp-let2
+ macroexp-copyable-p sym
+ (let* ((exp (nth 2 upat))
+ (found (assq exp vars)))
+ (if found (cdr found)
+ (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
+ (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
+ vs)))
+ (if env (macroexp-let* env exp) exp))))
+ (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
+ code vars rest)))
((eq (car-safe upat) '\`)
(put sym 'pcase-used t)
(pcase--q1 sym (cadr upat) matches code vars rest))
(let* ((elems (mapcar 'cadr (cdr upat)))
(splitrest
(pcase--split-rest
- sym (apply-partially #'pcase--split-member elems) rest))
+ sym (lambda (pat) (pcase--split-member elems pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
+ (put sym 'pcase-used t)
(pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest)))
(symd (make-symbol "xcdr"))
(splitrest (pcase--split-rest
sym
- (apply-partially #'pcase--split-consp syma symd)
+ (lambda (pat) (pcase--split-consp syma symd pat))
rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest))
;; The byte-compiler could do that for us, but it would have to pay
;; attention to the `consp' test in order to figure out that car/cdr
;; can't signal errors and our byte-compiler is not that clever.
- `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
+ ;; FIXME: Some of those let bindings occur too early (they are used in
+ ;; `then-body', but only within some sub-branch).
+ (macroexp-let*
+ `(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
- ,then-body)
+ then-body)
(pcase--u else-rest))))
((or (integerp qpat) (symbolp qpat) (stringp qpat))
(let* ((splitrest (pcase--split-rest
- sym (apply-partially 'pcase--split-equal qpat) rest))
+ sym (lambda (pat) (pcase--split-equal qpat pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
- (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat)
+ (pcase--if (cond
+ ((stringp qpat) `(equal ,sym ,qpat))
+ ((null qpat) `(null ,sym))
+ (t `(eq ,sym ',qpat)))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
(t (error "Unknown QPattern %s" qpat))))
HCoop / bpt / emacs.git / blobdiff