1 ;;; -*- lexical-binding: t -*-
2 ;;; pcase.el --- ML-style pattern-matching macro for Elisp
4 ;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
6 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; ML-style pattern matching.
27 ;; The entry points are autoloaded.
31 ;; - provide ways to extend the set of primitives, with some kind of
32 ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
33 ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
34 ;; But better would be if we could define new ways to match by having the
35 ;; extension provide its own `pcase--split-<foo>' thingy.
36 ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
37 ;; generate a lex-style DFA to decide whether to run E1 or E2.
41 (eval-when-compile (require 'cl
))
43 ;; Macro-expansion of pcase is reasonably fast, so it's not a problem
44 ;; when byte-compiling a file, but when interpreting the code, if the pcase
45 ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
46 ;; memoize previous macro expansions to try and avoid recomputing them
47 ;; over and over again.
48 (defconst pcase-memoize
(make-hash-table :weakness t
:test
'equal
))
50 (defconst pcase--dontcare-upats
'(t _ dontcare
))
53 (defmacro pcase
(exp &rest cases
)
54 "Perform ML-style pattern matching on EXP.
55 CASES is a list of elements of the form (UPATTERN CODE...).
57 UPatterns can take the following forms:
59 SYMBOL matches anything and binds it to SYMBOL.
60 (or UPAT...) matches if any of the patterns matches.
61 (and UPAT...) matches if all the patterns match.
62 `QPAT matches if the QPattern QPAT matches.
63 (pred PRED) matches if PRED applied to the object returns non-nil.
64 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
66 QPatterns can take the following forms:
67 (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
68 ,UPAT matches if the UPattern UPAT matches.
69 STRING matches if the object is `equal' to STRING.
70 ATOM matches if the object is `eq' to ATOM.
71 QPatterns for vectors are not implemented yet.
73 PRED can take the form
74 FUNCTION in which case it gets called with one argument.
75 (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments.
76 A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
77 PRED patterns can refer to variables bound earlier in the pattern.
78 E.g. you can match pairs where the cdr is larger than the car with a pattern
79 like `(,a . ,(pred (< a))) or, with more checks:
80 `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
81 (declare (indent 1) (debug case
)) ;FIXME: edebug `guard' and vars.
82 (or (gethash (cons exp cases
) pcase-memoize
)
83 (puthash (cons exp cases
)
84 (pcase--expand exp cases
)
88 (defmacro pcase-let
* (bindings &rest body
)
89 "Like `let*' but where you can use `pcase' patterns for bindings.
90 BODY should be an expression, and BINDINGS should be a list of bindings
91 of the form (UPAT EXP)."
92 (declare (indent 1) (debug let
))
94 ((null bindings
) (if (> (length body
) 1) `(progn ,@body
) (car body
)))
95 ((pcase--trivial-upat-p (caar bindings
))
96 `(let (,(car bindings
)) (pcase-let* ,(cdr bindings
) ,@body
)))
98 `(pcase ,(cadr (car bindings
))
99 (,(caar bindings
) (pcase-let* ,(cdr bindings
) ,@body
))
100 ;; We can either signal an error here, or just use `dontcare' which
101 ;; generates more efficient code. In practice, if we use `dontcare' we
102 ;; will still often get an error and the few cases where we don't do not
103 ;; matter that much, so it's a better choice.
107 (defmacro pcase-let
(bindings &rest body
)
108 "Like `let' but where you can use `pcase' patterns for bindings.
109 BODY should be a list of expressions, and BINDINGS should be a list of bindings
110 of the form (UPAT EXP)."
111 (declare (indent 1) (debug let
))
112 (if (null (cdr bindings
))
113 `(pcase-let* ,bindings
,@body
)
115 (dolist (binding (prog1 bindings
(setq bindings nil
)))
117 ((memq (car binding
) pcase--dontcare-upats
)
118 (push (cons (make-symbol "_") (cdr binding
)) bindings
))
119 ((pcase--trivial-upat-p (car binding
)) (push binding bindings
))
121 (let ((tmpvar (make-symbol (format "x%d" (length bindings
)))))
122 (push (cons tmpvar
(cdr binding
)) bindings
)
123 (push (list (car binding
) tmpvar
) matches
)))))
124 `(let ,(nreverse bindings
) (pcase-let* ,matches
,@body
)))))
126 (defmacro pcase-dolist
(spec &rest body
)
127 (if (pcase--trivial-upat-p (car spec
))
128 `(dolist ,spec
,@body
)
129 (let ((tmpvar (make-symbol "x")))
130 `(dolist (,tmpvar
,@(cdr spec
))
131 (pcase-let* ((,(car spec
) ,tmpvar
))
135 (defun pcase--trivial-upat-p (upat)
136 (and (symbolp upat
) (not (memq upat pcase--dontcare-upats
))))
138 (defun pcase--expand (exp cases
)
139 (let* ((defs (if (symbolp exp
) '()
140 (let ((sym (make-symbol "x")))
141 (prog1 `((,sym
,exp
)) (setq exp sym
)))))
145 (let ((prev (assq code seen
)))
147 (let ((res (pcase-codegen code vars
)))
148 (push (list code vars res
) seen
)
150 ;; Since we use a tree-based pattern matching
151 ;; technique, the leaves (the places that contain the
152 ;; code to run once a pattern is matched) can get
153 ;; copied a very large number of times, so to avoid
154 ;; code explosion, we need to keep track of how many
155 ;; times we've used each leaf and move it
156 ;; to a separate function if that number is too high.
158 ;; We've already used this branch. So it is shared.
159 (destructuring-bind (code prevvars res
) prev
160 (unless (symbolp res
)
161 ;; This is the first repeat, so we have to move
162 ;; the branch to a separate function.
164 (make-symbol (format "pcase-%d" (length defs
)))))
165 (push `(,bsym
(lambda ,(mapcar #'car prevvars
) ,@code
)) defs
)
166 (setcar res
'funcall
)
167 (setcdr res
(cons bsym
(mapcar #'cdr prevvars
)))
168 (setcar (cddr prev
) bsym
)
170 (setq vars
(copy-sequence vars
))
171 (let ((args (mapcar (lambda (pa)
172 (let ((v (assq (car pa
) vars
)))
173 (setq vars
(delq v vars
))
176 (when vars
;New additional vars.
177 (error "The vars %s are only bound in some paths"
178 (mapcar #'car vars
)))
179 `(funcall ,res
,@args
)))))))
182 (mapcar (lambda (case)
183 `((match ,exp .
,(car case
))
185 (if (pcase--small-branch-p (cdr case
))
186 ;; Don't bother sharing multiple
187 ;; occurrences of this leaf since it's small.
188 #'pcase-codegen codegen
)
192 `(let ,defs
,main
))))
194 (defun pcase-codegen (code vars
)
195 `(let ,(mapcar (lambda (b) (list (car b
) (cdr b
))) vars
)
198 (defun pcase--small-branch-p (code)
199 (and (= 1 (length code
))
200 (or (not (consp (car code
)))
202 (dolist (e (car code
))
203 (if (consp e
) (setq small nil
)))
206 ;; Try to use `cond' rather than a sequence of `if's, so as to reduce
207 ;; the depth of the generated tree.
208 (defun pcase--if (test then else
)
210 ((eq else
:pcase--dontcare
) then
)
211 ((eq (car-safe else
) 'if
)
212 (if (equal test
(nth 1 else
))
213 ;; Doing a test a second time: get rid of the redundancy.
214 ;; FIXME: ideally, this should never happen because the pcase--split-*
215 ;; funs should have eliminated such things, but pcase--split-member
216 ;; is imprecise, so in practice it can happen occasionally.
217 `(if ,test
,then
,@(nthcdr 3 else
))
219 (,(nth 1 else
) ,(nth 2 else
))
220 (t ,@(nthcdr 3 else
)))))
221 ((eq (car-safe else
) 'cond
)
223 ;; Doing a test a second time: get rid of the redundancy, as above.
224 ,@(remove (assoc test else
) (cdr else
))))
225 (t `(if ,test
,then
,else
))))
227 (defun pcase--upat (qpattern)
229 ((eq (car-safe qpattern
) '\
,) (cadr qpattern
))
230 (t (list '\
` qpattern
))))
233 ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
234 ;; check, we want to turn all the similar patterns into ones of the form
235 ;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
236 ;; Earlier code hence used branches of the form (MATCHES . CODE) where
237 ;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
238 ;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
239 ;; no easy way to eliminate the `consp' check in such a representation.
240 ;; So we replaced the MATCHES by the MATCH below which can be made up
241 ;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
242 ;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
243 ;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
244 ;; The downside is that we now have `or' and `and' both in MATCH and
245 ;; in PAT, so there are different equivalent representations and we
246 ;; need to handle them all. We do not try to systematically
247 ;; canonicalize them to one form over another, but we do occasionally
248 ;; turn one into the other.
250 (defun pcase--u (branches)
251 "Expand matcher for rules BRANCHES.
252 Each BRANCH has the form (MATCH CODE . VARS) where
253 CODE is the code generator for that branch.
254 VARS is the set of vars already bound by earlier matches.
255 MATCH is the pattern that needs to be matched, of the form:
259 (when (setq branches
(delq nil branches
))
260 (destructuring-bind (match code
&rest vars
) (car branches
)
261 (pcase--u1 (list match
) code vars
(cdr branches
)))))
263 (defun pcase--and (match matches
)
264 (if matches
`(and ,match
,@matches
) match
))
266 (defun pcase--split-match (sym splitter match
)
269 (if (not (eq sym
(cadr match
)))
271 (let ((pat (cddr match
)))
273 ;; Hoist `or' and `and' patterns to `or' and `and' matches.
274 ((memq (car-safe pat
) '(or and
))
275 (pcase--split-match sym splitter
277 (mapcar (lambda (alt)
278 `(match ,sym .
,alt
))
280 (t (let ((res (funcall splitter
(cddr match
))))
281 (cons (or (car res
) match
) (or (cdr res
) match
))))))))
283 (let ((then-alts '())
285 (neutral-elem (if (eq 'or
(car match
))
286 :pcase--fail
:pcase--succeed
))
287 (zero-elem (if (eq 'or
(car match
)) :pcase--succeed
:pcase--fail
)))
288 (dolist (alt (cdr match
))
289 (let ((split (pcase--split-match sym splitter alt
)))
290 (unless (eq (car split
) neutral-elem
)
291 (push (car split
) then-alts
))
292 (unless (eq (cdr split
) neutral-elem
)
293 (push (cdr split
) else-alts
))))
294 (cons (cond ((memq zero-elem then-alts
) zero-elem
)
295 ((null then-alts
) neutral-elem
)
296 ((null (cdr then-alts
)) (car then-alts
))
297 (t (cons (car match
) (nreverse then-alts
))))
298 (cond ((memq zero-elem else-alts
) zero-elem
)
299 ((null else-alts
) neutral-elem
)
300 ((null (cdr else-alts
)) (car else-alts
))
301 (t (cons (car match
) (nreverse else-alts
)))))))
302 (t (error "Uknown MATCH %s" match
))))
304 (defun pcase--split-rest (sym splitter rest
)
305 (let ((then-rest '())
307 (dolist (branch rest
)
308 (let* ((match (car branch
))
309 (code&vars
(cdr branch
))
311 (pcase--split-match sym splitter match
)))
312 (unless (eq (car splitted
) :pcase--fail
)
313 (push (cons (car splitted
) code
&vars
) then-rest
))
314 (unless (eq (cdr splitted
) :pcase--fail
)
315 (push (cons (cdr splitted
) code
&vars
) else-rest
))))
316 (cons (nreverse then-rest
) (nreverse else-rest
))))
318 (defun pcase--split-consp (syma symd pat
)
320 ;; A QPattern for a cons, can only go the `then' side.
321 ((and (eq (car-safe pat
) '\
`) (consp (cadr pat
)))
322 (let ((qpat (cadr pat
)))
323 (cons `(and (match ,syma .
,(pcase--upat (car qpat
)))
324 (match ,symd .
,(pcase--upat (cdr qpat
))))
326 ;; A QPattern but not for a cons, can only go the `else' side.
327 ((eq (car-safe pat
) '\
`) (cons :pcase--fail nil
))))
329 (defun pcase--split-equal (elem pat
)
331 ;; The same match will give the same result.
332 ((and (eq (car-safe pat
) '\
`) (equal (cadr pat
) elem
))
333 (cons :pcase--succeed
:pcase--fail
))
334 ;; A different match will fail if this one succeeds.
335 ((and (eq (car-safe pat
) '\
`)
336 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
337 ;; (consp (cadr pat)))
339 (cons :pcase--fail nil
))))
341 (defun pcase--split-member (elems pat
)
342 ;; Based on pcase--split-equal.
344 ;; The same match (or a match of membership in a superset) will
345 ;; give the same result, but we don't know how to check it.
347 ;; (cons :pcase--succeed nil))
348 ;; A match for one of the elements may succeed or fail.
349 ((and (eq (car-safe pat
) '\
`) (member (cadr pat
) elems
))
351 ;; A different match will fail if this one succeeds.
352 ((and (eq (car-safe pat
) '\
`)
353 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
354 ;; (consp (cadr pat)))
356 (cons :pcase--fail nil
))))
358 (defun pcase--split-pred (upat pat
)
359 ;; FIXME: For predicates like (pred (> a)), two such predicates may
360 ;; actually refer to different variables `a'.
362 (cons :pcase--succeed
:pcase--fail
)))
364 (defun pcase--fgrep (vars sexp
)
365 "Check which of the symbols VARS appear in SEXP."
368 (dolist (var (pcase--fgrep vars
(pop sexp
)))
369 (unless (memq var res
) (push var res
))))
370 (and (memq sexp vars
) (not (memq sexp res
)) (push sexp res
))
373 ;; It's very tempting to use `pcase' below, tho obviously, it'd create
374 ;; bootstrapping problems.
375 (defun pcase--u1 (matches code vars rest
)
376 "Return code that runs CODE (with VARS) if MATCHES match.
377 and otherwise defers to REST which is a list of branches of the form
378 \(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
379 ;; Depending on the order in which we choose to check each of the MATCHES,
380 ;; the resulting tree may be smaller or bigger. So in general, we'd want
381 ;; to be careful to chose the "optimal" order. But predicate
382 ;; patterns make this harder because they create dependencies
383 ;; between matches. So we don't bother trying to reorder anything.
385 ((null matches
) (funcall code vars
))
386 ((eq :pcase--fail
(car matches
)) (pcase--u rest
))
387 ((eq :pcase--succeed
(car matches
))
388 (pcase--u1 (cdr matches
) code vars rest
))
389 ((eq 'and
(caar matches
))
390 (pcase--u1 (append (cdar matches
) (cdr matches
)) code vars rest
))
391 ((eq 'or
(caar matches
))
392 (let* ((alts (cdar matches
))
393 (var (if (eq (caar alts
) 'match
) (cadr (car alts
))))
394 (simples '()) (others '()))
397 (if (and (eq (car alt
) 'match
) (eq var
(cadr alt
))
398 (let ((upat (cddr alt
)))
399 (and (eq (car-safe upat
) '\
`)
400 (or (integerp (cadr upat
)) (symbolp (cadr upat
))
401 (stringp (cadr upat
))))))
402 (push (cddr alt
) simples
)
405 ((null alts
) (error "Please avoid it") (pcase--u rest
))
406 ((> (length simples
) 1)
407 ;; De-hoist the `or' MATCH into an `or' pattern that will be
408 ;; turned into a `memq' below.
409 (pcase--u1 (cons `(match ,var or .
,(nreverse simples
)) (cdr matches
))
411 (if (null others
) rest
413 (pcase--and (if (cdr others
)
414 (cons 'or
(nreverse others
))
420 (pcase--u1 (cons (pop alts
) (cdr matches
)) code vars
421 (if (null alts
) (progn (error "Please avoid it") rest
)
423 (pcase--and (if (cdr alts
)
424 (cons 'or alts
) (car alts
))
428 ((eq 'match
(caar matches
))
429 (destructuring-bind (op sym
&rest upat
) (pop matches
)
431 ((memq upat
'(t _
)) (pcase--u1 matches code vars rest
))
432 ((eq upat
'dontcare
) :pcase--dontcare
)
433 ((functionp upat
) (error "Feature removed, use (pred %s)" upat
))
434 ((memq (car-safe upat
) '(guard pred
))
435 (destructuring-bind (then-rest &rest else-rest
)
437 sym
(apply-partially #'pcase--split-pred upat
) rest
)
438 (pcase--if (if (and (eq (car upat
) 'pred
) (symbolp (cadr upat
)))
440 (let* ((exp (cadr upat
))
441 ;; `vs' is an upper bound on the vars we need.
442 (vs (pcase--fgrep (mapcar #'car vars
) exp
))
444 ((eq 'guard
(car upat
)) exp
)
445 ((functionp exp
) `(,exp
,sym
))
449 ;; Let's not replace `vars' in `exp' since it's
450 ;; too difficult to do it right, instead just
451 ;; let-bind `vars' around `exp'.
452 `(let ,(mapcar (lambda (var)
453 (list var
(cdr (assq var vars
))))
455 ;; FIXME: `vars' can capture `sym'. E.g.
456 ;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
458 (pcase--u1 matches code vars then-rest
)
459 (pcase--u else-rest
))))
461 (pcase--u1 matches code
(cons (cons upat sym
) vars
) rest
))
462 ((eq (car-safe upat
) '\
`)
463 (pcase--q1 sym
(cadr upat
) matches code vars rest
))
464 ((eq (car-safe upat
) 'or
)
465 (let ((all (> (length (cdr upat
)) 1))
468 (dolist (alt (cdr upat
))
469 (unless (and (eq (car-safe alt
) '\
`)
470 (or (symbolp (cadr alt
)) (integerp (cadr alt
))
472 (stringp (cadr alt
))))
475 ;; Use memq for (or `a `b `c `d) rather than a big tree.
476 (let ((elems (mapcar 'cadr
(cdr upat
))))
477 (destructuring-bind (then-rest &rest else-rest
)
479 sym
(apply-partially #'pcase--split-member elems
) rest
)
480 (pcase--if `(,(if memq-fine
#'memq
#'member
) ,sym
',elems
)
481 (pcase--u1 matches code vars then-rest
)
482 (pcase--u else-rest
))))
483 (pcase--u1 (cons `(match ,sym
,@(cadr upat
)) matches
) code vars
484 (append (mapcar (lambda (upat)
485 `((and (match ,sym .
,upat
) ,@matches
)
489 ((eq (car-safe upat
) 'and
)
490 (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym
,@upat
))
494 ((eq (car-safe upat
) 'not
)
495 ;; FIXME: The implementation below is naive and results in
497 ;; To make it work right, we would need to turn pcase--u1's
498 ;; `code' and `vars' into a single argument of the same form as
499 ;; `rest'. We would also need to split this new `then-rest' argument
500 ;; for every test (currently we don't bother to do it since
501 ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
502 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
503 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
504 (pcase--u1 `((match ,sym .
,(cadr upat
)))
505 ;; FIXME: This codegen is not careful to share its
506 ;; code if used several times: code blow up is likely.
508 ;; `vars' will likely contain bindings which are
509 ;; not always available in other paths to
510 ;; `rest', so there' no point trying to pass
514 (list `((and .
,matches
) ,code .
,vars
))))
515 (t (error "Unknown upattern `%s'" upat
)))))
516 (t (error "Incorrect MATCH %s" (car matches
)))))
518 (defun pcase--q1 (sym qpat matches code vars rest
)
519 "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
520 and if not, defers to REST which is a list of branches of the form
521 \(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
523 ((eq (car-safe qpat
) '\
,) (error "Can't use `,UPATTERN"))
524 ((floatp qpat
) (error "Floating point patterns not supported"))
527 (error "Vector QPatterns not implemented yet"))
529 (let ((syma (make-symbol "xcar"))
530 (symd (make-symbol "xcdr")))
531 (destructuring-bind (then-rest &rest else-rest
)
532 (pcase--split-rest sym
533 (apply-partially #'pcase--split-consp syma symd
)
535 (pcase--if `(consp ,sym
)
536 `(let ((,syma
(car ,sym
))
538 ,(pcase--u1 `((match ,syma .
,(pcase--upat (car qpat
)))
539 (match ,symd .
,(pcase--upat (cdr qpat
)))
541 code vars then-rest
))
542 (pcase--u else-rest
)))))
543 ((or (integerp qpat
) (symbolp qpat
) (stringp qpat
))
544 (destructuring-bind (then-rest &rest else-rest
)
545 (pcase--split-rest sym
(apply-partially 'pcase--split-equal qpat
) rest
)
546 (pcase--if `(,(if (stringp qpat
) #'equal
#'eq
) ,sym
',qpat
)
547 (pcase--u1 matches code vars then-rest
)
548 (pcase--u else-rest
))))
549 (t (error "Unkown QPattern %s" qpat
))))
553 ;;; pcase.el ends here