Commit | Line | Data |
---|---|---|
513749ee | 1 | ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*- |
d02c9bcd | 2 | |
acaf905b | 3 | ;; Copyright (C) 2010-2012 Free Software Foundation, Inc. |
d02c9bcd SM |
4 | |
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
ca3afb79 | 6 | ;; Keywords: |
d02c9bcd SM |
7 | |
8 | ;; This file is part of GNU Emacs. | |
9 | ||
10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation, either version 3 of the License, or | |
13 | ;; (at your option) any later version. | |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | ;;; Commentary: | |
24 | ||
25 | ;; ML-style pattern matching. | |
26 | ;; The entry points are autoloaded. | |
27 | ||
dcc029e0 SM |
28 | ;; Todo: |
29 | ||
ca105506 SM |
30 | ;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't |
31 | ;; use x, because x is bound separately for the equality constraint | |
32 | ;; (as well as any pred/guard) and for the body, so uses at one place don't | |
33 | ;; count for the other. | |
dcc029e0 SM |
34 | ;; - provide ways to extend the set of primitives, with some kind of |
35 | ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) | |
36 | ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). | |
37 | ;; But better would be if we could define new ways to match by having the | |
872ab164 | 38 | ;; extension provide its own `pcase--split-<foo>' thingy. |
ca105506 | 39 | ;; - along these lines, provide patterns to match CL structs. |
1f0816b6 SM |
40 | ;; - provide something like (setq VAR) so a var can be set rather than |
41 | ;; let-bound. | |
a179e3f7 SM |
42 | ;; - provide a way to fallthrough to subsequent cases (not sure what I meant by |
43 | ;; this :-() | |
1f0816b6 | 44 | ;; - try and be more clever to reduce the size of the decision tree, and |
ca105506 | 45 | ;; to reduce the number of leaves that need to be turned into function: |
1f0816b6 | 46 | ;; - first, do the tests shared by all remaining branches (it will have |
a179e3f7 | 47 | ;; to be performed anyway, so better do it first so it's shared). |
1f0816b6 | 48 | ;; - then choose the test that discriminates more (?). |
a179e3f7 SM |
49 | ;; - provide Agda's `with' (along with its `...' companion). |
50 | ;; - implement (not UPAT). This might require a significant redesign. | |
dcc029e0 SM |
51 | ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to |
52 | ;; generate a lex-style DFA to decide whether to run E1 or E2. | |
53 | ||
d02c9bcd SM |
54 | ;;; Code: |
55 | ||
4dd1c416 SM |
56 | (require 'macroexp) |
57 | ||
d02c9bcd SM |
58 | ;; Macro-expansion of pcase is reasonably fast, so it's not a problem |
59 | ;; when byte-compiling a file, but when interpreting the code, if the pcase | |
60 | ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we | |
61 | ;; memoize previous macro expansions to try and avoid recomputing them | |
62 | ;; over and over again. | |
e2abe5a1 | 63 | (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) |
82ad98e3 SM |
64 | ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) |
65 | ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) | |
d02c9bcd | 66 | |
872ab164 SM |
67 | (defconst pcase--dontcare-upats '(t _ dontcare)) |
68 | ||
a4712e11 JB |
69 | (def-edebug-spec |
70 | pcase-UPAT | |
71 | (&or symbolp | |
72 | ("or" &rest pcase-UPAT) | |
73 | ("and" &rest pcase-UPAT) | |
74 | ("`" pcase-QPAT) | |
75 | ("guard" form) | |
76 | ("let" pcase-UPAT form) | |
77 | ("pred" | |
78 | &or lambda-expr | |
79 | ;; Punt on macros/special forms. | |
80 | (functionp &rest form) | |
81 | sexp) | |
82 | sexp)) | |
83 | ||
84 | (def-edebug-spec | |
85 | pcase-QPAT | |
86 | (&or ("," pcase-UPAT) | |
87 | (pcase-QPAT . pcase-QPAT) | |
88 | sexp)) | |
89 | ||
d02c9bcd SM |
90 | ;;;###autoload |
91 | (defmacro pcase (exp &rest cases) | |
92 | "Perform ML-style pattern matching on EXP. | |
93 | CASES is a list of elements of the form (UPATTERN CODE...). | |
94 | ||
95 | UPatterns can take the following forms: | |
96 | _ matches anything. | |
97 | SYMBOL matches anything and binds it to SYMBOL. | |
98 | (or UPAT...) matches if any of the patterns matches. | |
99 | (and UPAT...) matches if all the patterns match. | |
100 | `QPAT matches if the QPattern QPAT matches. | |
101 | (pred PRED) matches if PRED applied to the object returns non-nil. | |
dcc029e0 | 102 | (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. |
ca105506 | 103 | (let UPAT EXP) matches if EXP matches UPAT. |
f9d554dd SM |
104 | If a SYMBOL is used twice in the same pattern (i.e. the pattern is |
105 | \"non-linear\"), then the second occurrence is turned into an `eq'uality test. | |
d02c9bcd SM |
106 | |
107 | QPatterns can take the following forms: | |
108 | (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. | |
109 | ,UPAT matches if the UPattern UPAT matches. | |
ca3afb79 | 110 | STRING matches if the object is `equal' to STRING. |
d02c9bcd SM |
111 | ATOM matches if the object is `eq' to ATOM. |
112 | QPatterns for vectors are not implemented yet. | |
113 | ||
114 | PRED can take the form | |
ca3afb79 | 115 | FUNCTION in which case it gets called with one argument. |
d02c9bcd SM |
116 | (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments. |
117 | A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). | |
118 | PRED patterns can refer to variables bound earlier in the pattern. | |
119 | E.g. you can match pairs where the cdr is larger than the car with a pattern | |
120 | like `(,a . ,(pred (< a))) or, with more checks: | |
121 | `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" | |
a4712e11 | 122 | (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) |
e2abe5a1 SM |
123 | ;; We want to use a weak hash table as a cache, but the key will unavoidably |
124 | ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time | |
125 | ;; we're called so it'll be immediately GC'd. So we use (car cases) as key | |
126 | ;; which does come straight from the source code and should hence not be GC'd | |
127 | ;; so easily. | |
128 | (let ((data (gethash (car cases) pcase--memoize))) | |
129 | ;; data = (EXP CASES . EXPANSION) | |
130 | (if (and (equal exp (car data)) (equal cases (cadr data))) | |
131 | ;; We have the right expansion. | |
132 | (cddr data) | |
82ad98e3 SM |
133 | ;; (when (gethash (car cases) pcase--memoize-1) |
134 | ;; (message "pcase-memoize failed because of weak key!!")) | |
135 | ;; (when (gethash (car cases) pcase--memoize-2) | |
136 | ;; (message "pcase-memoize failed because of eq test on %S" | |
137 | ;; (car cases))) | |
e2abe5a1 SM |
138 | (when data |
139 | (message "pcase-memoize: equal first branch, yet different")) | |
140 | (let ((expansion (pcase--expand exp cases))) | |
82ad98e3 SM |
141 | (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize) |
142 | ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1) | |
143 | ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) | |
e2abe5a1 | 144 | expansion)))) |
d02c9bcd | 145 | |
82ad98e3 SM |
146 | (defun pcase--let* (bindings body) |
147 | (cond | |
148 | ((null bindings) (macroexp-progn body)) | |
149 | ((pcase--trivial-upat-p (caar bindings)) | |
150 | (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body))) | |
151 | (t | |
152 | (let ((binding (pop bindings))) | |
153 | (pcase--expand | |
154 | (cadr binding) | |
155 | `((,(car binding) ,(pcase--let* bindings body)) | |
156 | ;; We can either signal an error here, or just use `dontcare' which | |
157 | ;; generates more efficient code. In practice, if we use `dontcare' | |
158 | ;; we will still often get an error and the few cases where we don't | |
159 | ;; do not matter that much, so it's a better choice. | |
160 | (dontcare nil))))))) | |
161 | ||
d02c9bcd | 162 | ;;;###autoload |
872ab164 | 163 | (defmacro pcase-let* (bindings &rest body) |
d02c9bcd SM |
164 | "Like `let*' but where you can use `pcase' patterns for bindings. |
165 | BODY should be an expression, and BINDINGS should be a list of bindings | |
166 | of the form (UPAT EXP)." | |
c41045e6 | 167 | (declare (indent 1) |
a4712e11 | 168 | (debug ((&rest (pcase-UPAT &optional form)) body))) |
82ad98e3 SM |
169 | (let ((cached (gethash bindings pcase--memoize))) |
170 | ;; cached = (BODY . EXPANSION) | |
171 | (if (equal (car cached) body) | |
172 | (cdr cached) | |
173 | (let ((expansion (pcase--let* bindings body))) | |
174 | (puthash bindings (cons body expansion) pcase--memoize) | |
175 | expansion)))) | |
d02c9bcd SM |
176 | |
177 | ;;;###autoload | |
872ab164 | 178 | (defmacro pcase-let (bindings &rest body) |
d02c9bcd | 179 | "Like `let' but where you can use `pcase' patterns for bindings. |
872ab164 | 180 | BODY should be a list of expressions, and BINDINGS should be a list of bindings |
d02c9bcd | 181 | of the form (UPAT EXP)." |
c41045e6 | 182 | (declare (indent 1) (debug pcase-let*)) |
d02c9bcd | 183 | (if (null (cdr bindings)) |
872ab164 SM |
184 | `(pcase-let* ,bindings ,@body) |
185 | (let ((matches '())) | |
186 | (dolist (binding (prog1 bindings (setq bindings nil))) | |
187 | (cond | |
188 | ((memq (car binding) pcase--dontcare-upats) | |
189 | (push (cons (make-symbol "_") (cdr binding)) bindings)) | |
190 | ((pcase--trivial-upat-p (car binding)) (push binding bindings)) | |
191 | (t | |
192 | (let ((tmpvar (make-symbol (format "x%d" (length bindings))))) | |
193 | (push (cons tmpvar (cdr binding)) bindings) | |
194 | (push (list (car binding) tmpvar) matches))))) | |
195 | `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) | |
196 | ||
197 | (defmacro pcase-dolist (spec &rest body) | |
a4712e11 | 198 | (declare (indent 1) (debug ((pcase-UPAT form) body))) |
872ab164 SM |
199 | (if (pcase--trivial-upat-p (car spec)) |
200 | `(dolist ,spec ,@body) | |
201 | (let ((tmpvar (make-symbol "x"))) | |
202 | `(dolist (,tmpvar ,@(cdr spec)) | |
203 | (pcase-let* ((,(car spec) ,tmpvar)) | |
204 | ,@body))))) | |
205 | ||
206 | ||
207 | (defun pcase--trivial-upat-p (upat) | |
208 | (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) | |
209 | ||
210 | (defun pcase--expand (exp cases) | |
e2abe5a1 SM |
211 | ;; (message "pid=%S (pcase--expand %S ...hash=%S)" |
212 | ;; (emacs-pid) exp (sxhash cases)) | |
2ee3d7f0 | 213 | (macroexp-let2 macroexp-copyable-p val exp |
82ad98e3 SM |
214 | (let* ((defs ()) |
215 | (seen '()) | |
216 | (codegen | |
217 | (lambda (code vars) | |
218 | (let ((prev (assq code seen))) | |
219 | (if (not prev) | |
220 | (let ((res (pcase-codegen code vars))) | |
221 | (push (list code vars res) seen) | |
222 | res) | |
223 | ;; Since we use a tree-based pattern matching | |
224 | ;; technique, the leaves (the places that contain the | |
225 | ;; code to run once a pattern is matched) can get | |
226 | ;; copied a very large number of times, so to avoid | |
227 | ;; code explosion, we need to keep track of how many | |
228 | ;; times we've used each leaf and move it | |
229 | ;; to a separate function if that number is too high. | |
230 | ;; | |
231 | ;; We've already used this branch. So it is shared. | |
232 | (let* ((code (car prev)) (cdrprev (cdr prev)) | |
233 | (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) | |
234 | (res (car cddrprev))) | |
235 | (unless (symbolp res) | |
236 | ;; This is the first repeat, so we have to move | |
237 | ;; the branch to a separate function. | |
238 | (let ((bsym | |
239 | (make-symbol (format "pcase-%d" (length defs))))) | |
ee4b1330 SM |
240 | (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) |
241 | defs) | |
82ad98e3 SM |
242 | (setcar res 'funcall) |
243 | (setcdr res (cons bsym (mapcar #'cdr prevvars))) | |
244 | (setcar (cddr prev) bsym) | |
245 | (setq res bsym))) | |
246 | (setq vars (copy-sequence vars)) | |
247 | (let ((args (mapcar (lambda (pa) | |
248 | (let ((v (assq (car pa) vars))) | |
249 | (setq vars (delq v vars)) | |
250 | (cdr v))) | |
251 | prevvars))) | |
252 | ;; If some of `vars' were not found in `prevvars', that's | |
253 | ;; OK it just means those vars aren't present in all | |
254 | ;; branches, so they can be used within the pattern | |
255 | ;; (e.g. by a `guard/let/pred') but not in the branch. | |
256 | ;; FIXME: But if some of `prevvars' are not in `vars' we | |
257 | ;; should remove them from `prevvars'! | |
258 | `(funcall ,res ,@args))))))) | |
ee4b1330 | 259 | (used-cases ()) |
82ad98e3 SM |
260 | (main |
261 | (pcase--u | |
262 | (mapcar (lambda (case) | |
263 | `((match ,val . ,(car case)) | |
ee4b1330 SM |
264 | ,(lambda (vars) |
265 | (unless (memq case used-cases) | |
266 | ;; Keep track of the cases that are used. | |
267 | (push case used-cases)) | |
268 | (funcall | |
269 | (if (pcase--small-branch-p (cdr case)) | |
270 | ;; Don't bother sharing multiple | |
271 | ;; occurrences of this leaf since it's small. | |
272 | #'pcase-codegen codegen) | |
273 | (cdr case) | |
274 | vars)))) | |
82ad98e3 | 275 | cases)))) |
ee4b1330 SM |
276 | (dolist (case cases) |
277 | (unless (or (memq case used-cases) (eq (car case) 'dontcare)) | |
278 | (message "Redundant pcase pattern: %S" (car case)))) | |
4dd1c416 | 279 | (macroexp-let* defs main)))) |
d02c9bcd SM |
280 | |
281 | (defun pcase-codegen (code vars) | |
4dd1c416 | 282 | ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding |
6876a58d SM |
283 | ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy |
284 | ;; codegen from later metamorphosing this let into a funcall. | |
285 | `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) | |
d02c9bcd SM |
286 | ,@code)) |
287 | ||
872ab164 | 288 | (defun pcase--small-branch-p (code) |
d02c9bcd SM |
289 | (and (= 1 (length code)) |
290 | (or (not (consp (car code))) | |
291 | (let ((small t)) | |
292 | (dolist (e (car code)) | |
293 | (if (consp e) (setq small nil))) | |
294 | small)))) | |
295 | ||
296 | ;; Try to use `cond' rather than a sequence of `if's, so as to reduce | |
297 | ;; the depth of the generated tree. | |
872ab164 | 298 | (defun pcase--if (test then else) |
d02c9bcd | 299 | (cond |
872ab164 | 300 | ((eq else :pcase--dontcare) then) |
1f0816b6 | 301 | ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? |
4dd1c416 | 302 | (t (macroexp-if test then else)))) |
5342bb06 | 303 | |
872ab164 | 304 | (defun pcase--upat (qpattern) |
d02c9bcd SM |
305 | (cond |
306 | ((eq (car-safe qpattern) '\,) (cadr qpattern)) | |
307 | (t (list '\` qpattern)))) | |
308 | ||
309 | ;; Note about MATCH: | |
310 | ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp' | |
311 | ;; check, we want to turn all the similar patterns into ones of the form | |
312 | ;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction. | |
313 | ;; Earlier code hence used branches of the form (MATCHES . CODE) where | |
314 | ;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT). | |
315 | ;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is | |
316 | ;; no easy way to eliminate the `consp' check in such a representation. | |
317 | ;; So we replaced the MATCHES by the MATCH below which can be made up | |
318 | ;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can | |
319 | ;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into | |
320 | ;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)). | |
321 | ;; The downside is that we now have `or' and `and' both in MATCH and | |
322 | ;; in PAT, so there are different equivalent representations and we | |
323 | ;; need to handle them all. We do not try to systematically | |
324 | ;; canonicalize them to one form over another, but we do occasionally | |
325 | ;; turn one into the other. | |
326 | ||
872ab164 | 327 | (defun pcase--u (branches) |
d02c9bcd SM |
328 | "Expand matcher for rules BRANCHES. |
329 | Each BRANCH has the form (MATCH CODE . VARS) where | |
330 | CODE is the code generator for that branch. | |
331 | VARS is the set of vars already bound by earlier matches. | |
332 | MATCH is the pattern that needs to be matched, of the form: | |
333 | (match VAR . UPAT) | |
334 | (and MATCH ...) | |
335 | (or MATCH ...)" | |
336 | (when (setq branches (delq nil branches)) | |
9a05edc4 SM |
337 | (let* ((carbranch (car branches)) |
338 | (match (car carbranch)) (cdarbranch (cdr carbranch)) | |
339 | (code (car cdarbranch)) | |
340 | (vars (cdr cdarbranch))) | |
872ab164 | 341 | (pcase--u1 (list match) code vars (cdr branches))))) |
d02c9bcd | 342 | |
872ab164 | 343 | (defun pcase--and (match matches) |
d02c9bcd SM |
344 | (if matches `(and ,match ,@matches) match)) |
345 | ||
1f0816b6 SM |
346 | (defconst pcase-mutually-exclusive-predicates |
347 | '((symbolp . integerp) | |
348 | (symbolp . numberp) | |
349 | (symbolp . consp) | |
350 | (symbolp . arrayp) | |
351 | (symbolp . stringp) | |
ca105506 | 352 | (symbolp . byte-code-function-p) |
1f0816b6 SM |
353 | (integerp . consp) |
354 | (integerp . arrayp) | |
355 | (integerp . stringp) | |
ca105506 | 356 | (integerp . byte-code-function-p) |
1f0816b6 SM |
357 | (numberp . consp) |
358 | (numberp . arrayp) | |
359 | (numberp . stringp) | |
ca105506 | 360 | (numberp . byte-code-function-p) |
1f0816b6 SM |
361 | (consp . arrayp) |
362 | (consp . stringp) | |
ca105506 SM |
363 | (consp . byte-code-function-p) |
364 | (arrayp . stringp) | |
365 | (arrayp . byte-code-function-p) | |
366 | (stringp . byte-code-function-p))) | |
1f0816b6 | 367 | |
872ab164 | 368 | (defun pcase--split-match (sym splitter match) |
9a05edc4 SM |
369 | (cond |
370 | ((eq (car match) 'match) | |
d02c9bcd SM |
371 | (if (not (eq sym (cadr match))) |
372 | (cons match match) | |
373 | (let ((pat (cddr match))) | |
374 | (cond | |
375 | ;; Hoist `or' and `and' patterns to `or' and `and' matches. | |
376 | ((memq (car-safe pat) '(or and)) | |
872ab164 SM |
377 | (pcase--split-match sym splitter |
378 | (cons (car pat) | |
379 | (mapcar (lambda (alt) | |
380 | `(match ,sym . ,alt)) | |
381 | (cdr pat))))) | |
d02c9bcd SM |
382 | (t (let ((res (funcall splitter (cddr match)))) |
383 | (cons (or (car res) match) (or (cdr res) match)))))))) | |
9a05edc4 | 384 | ((memq (car match) '(or and)) |
d02c9bcd SM |
385 | (let ((then-alts '()) |
386 | (else-alts '()) | |
872ab164 SM |
387 | (neutral-elem (if (eq 'or (car match)) |
388 | :pcase--fail :pcase--succeed)) | |
389 | (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail))) | |
d02c9bcd | 390 | (dolist (alt (cdr match)) |
872ab164 | 391 | (let ((split (pcase--split-match sym splitter alt))) |
d02c9bcd SM |
392 | (unless (eq (car split) neutral-elem) |
393 | (push (car split) then-alts)) | |
394 | (unless (eq (cdr split) neutral-elem) | |
395 | (push (cdr split) else-alts)))) | |
396 | (cons (cond ((memq zero-elem then-alts) zero-elem) | |
397 | ((null then-alts) neutral-elem) | |
398 | ((null (cdr then-alts)) (car then-alts)) | |
399 | (t (cons (car match) (nreverse then-alts)))) | |
400 | (cond ((memq zero-elem else-alts) zero-elem) | |
401 | ((null else-alts) neutral-elem) | |
402 | ((null (cdr else-alts)) (car else-alts)) | |
403 | (t (cons (car match) (nreverse else-alts))))))) | |
404 | (t (error "Uknown MATCH %s" match)))) | |
405 | ||
872ab164 | 406 | (defun pcase--split-rest (sym splitter rest) |
d02c9bcd SM |
407 | (let ((then-rest '()) |
408 | (else-rest '())) | |
409 | (dolist (branch rest) | |
410 | (let* ((match (car branch)) | |
411 | (code&vars (cdr branch)) | |
bbd240ce | 412 | (split |
872ab164 | 413 | (pcase--split-match sym splitter match))) |
bbd240ce PE |
414 | (unless (eq (car split) :pcase--fail) |
415 | (push (cons (car split) code&vars) then-rest)) | |
416 | (unless (eq (cdr split) :pcase--fail) | |
417 | (push (cons (cdr split) code&vars) else-rest)))) | |
d02c9bcd SM |
418 | (cons (nreverse then-rest) (nreverse else-rest)))) |
419 | ||
872ab164 | 420 | (defun pcase--split-consp (syma symd pat) |
d02c9bcd SM |
421 | (cond |
422 | ;; A QPattern for a cons, can only go the `then' side. | |
423 | ((and (eq (car-safe pat) '\`) (consp (cadr pat))) | |
424 | (let ((qpat (cadr pat))) | |
872ab164 SM |
425 | (cons `(and (match ,syma . ,(pcase--upat (car qpat))) |
426 | (match ,symd . ,(pcase--upat (cdr qpat)))) | |
427 | :pcase--fail))) | |
1f0816b6 SM |
428 | ;; A QPattern but not for a cons, can only go to the `else' side. |
429 | ((eq (car-safe pat) '\`) (cons :pcase--fail nil)) | |
430 | ((and (eq (car-safe pat) 'pred) | |
431 | (or (member (cons 'consp (cadr pat)) | |
432 | pcase-mutually-exclusive-predicates) | |
433 | (member (cons (cadr pat) 'consp) | |
434 | pcase-mutually-exclusive-predicates))) | |
435 | (cons :pcase--fail nil)))) | |
d02c9bcd | 436 | |
872ab164 | 437 | (defun pcase--split-equal (elem pat) |
d02c9bcd SM |
438 | (cond |
439 | ;; The same match will give the same result. | |
440 | ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) | |
872ab164 | 441 | (cons :pcase--succeed :pcase--fail)) |
d02c9bcd SM |
442 | ;; A different match will fail if this one succeeds. |
443 | ((and (eq (car-safe pat) '\`) | |
444 | ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) | |
445 | ;; (consp (cadr pat))) | |
446 | ) | |
1f0816b6 SM |
447 | (cons :pcase--fail nil)) |
448 | ((and (eq (car-safe pat) 'pred) | |
449 | (symbolp (cadr pat)) | |
450 | (get (cadr pat) 'side-effect-free) | |
451 | (funcall (cadr pat) elem)) | |
452 | (cons :pcase--succeed nil)))) | |
d02c9bcd | 453 | |
872ab164 SM |
454 | (defun pcase--split-member (elems pat) |
455 | ;; Based on pcase--split-equal. | |
d02c9bcd | 456 | (cond |
dcc029e0 SM |
457 | ;; The same match (or a match of membership in a superset) will |
458 | ;; give the same result, but we don't know how to check it. | |
4de81ee0 | 459 | ;; (??? |
872ab164 | 460 | ;; (cons :pcase--succeed nil)) |
4de81ee0 | 461 | ;; A match for one of the elements may succeed or fail. |
d02c9bcd | 462 | ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) |
4de81ee0 | 463 | nil) |
d02c9bcd SM |
464 | ;; A different match will fail if this one succeeds. |
465 | ((and (eq (car-safe pat) '\`) | |
466 | ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) | |
467 | ;; (consp (cadr pat))) | |
468 | ) | |
1f0816b6 SM |
469 | (cons :pcase--fail nil)) |
470 | ((and (eq (car-safe pat) 'pred) | |
471 | (symbolp (cadr pat)) | |
472 | (get (cadr pat) 'side-effect-free) | |
473 | (let ((p (cadr pat)) (all t)) | |
474 | (dolist (elem elems) | |
475 | (unless (funcall p elem) (setq all nil))) | |
476 | all)) | |
477 | (cons :pcase--succeed nil)))) | |
d02c9bcd | 478 | |
872ab164 | 479 | (defun pcase--split-pred (upat pat) |
d02c9bcd SM |
480 | ;; FIXME: For predicates like (pred (> a)), two such predicates may |
481 | ;; actually refer to different variables `a'. | |
5342bb06 SM |
482 | (let (test) |
483 | (cond | |
484 | ((equal upat pat) (cons :pcase--succeed :pcase--fail)) | |
485 | ((and (eq 'pred (car upat)) | |
486 | (eq 'pred (car-safe pat)) | |
487 | (or (member (cons (cadr upat) (cadr pat)) | |
488 | pcase-mutually-exclusive-predicates) | |
489 | (member (cons (cadr pat) (cadr upat)) | |
490 | pcase-mutually-exclusive-predicates))) | |
491 | (cons :pcase--fail nil)) | |
492 | ((and (eq 'pred (car upat)) | |
493 | (eq '\` (car-safe pat)) | |
494 | (symbolp (cadr upat)) | |
495 | (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) | |
496 | (get (cadr upat) 'side-effect-free) | |
497 | (ignore-errors | |
498 | (setq test (list (funcall (cadr upat) (cadr pat)))))) | |
499 | (if (car test) | |
500 | (cons nil :pcase--fail) | |
501 | (cons :pcase--fail nil)))))) | |
d02c9bcd | 502 | |
872ab164 | 503 | (defun pcase--fgrep (vars sexp) |
d02c9bcd SM |
504 | "Check which of the symbols VARS appear in SEXP." |
505 | (let ((res '())) | |
506 | (while (consp sexp) | |
872ab164 | 507 | (dolist (var (pcase--fgrep vars (pop sexp))) |
d02c9bcd SM |
508 | (unless (memq var res) (push var res)))) |
509 | (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) | |
510 | res)) | |
511 | ||
512 | ;; It's very tempting to use `pcase' below, tho obviously, it'd create | |
513 | ;; bootstrapping problems. | |
872ab164 | 514 | (defun pcase--u1 (matches code vars rest) |
d02c9bcd | 515 | "Return code that runs CODE (with VARS) if MATCHES match. |
ca3afb79 | 516 | Otherwise, it defers to REST which is a list of branches of the form |
d02c9bcd SM |
517 | \(ELSE-MATCH ELSE-CODE . ELSE-VARS)." |
518 | ;; Depending on the order in which we choose to check each of the MATCHES, | |
519 | ;; the resulting tree may be smaller or bigger. So in general, we'd want | |
520 | ;; to be careful to chose the "optimal" order. But predicate | |
521 | ;; patterns make this harder because they create dependencies | |
522 | ;; between matches. So we don't bother trying to reorder anything. | |
523 | (cond | |
524 | ((null matches) (funcall code vars)) | |
872ab164 SM |
525 | ((eq :pcase--fail (car matches)) (pcase--u rest)) |
526 | ((eq :pcase--succeed (car matches)) | |
527 | (pcase--u1 (cdr matches) code vars rest)) | |
d02c9bcd | 528 | ((eq 'and (caar matches)) |
872ab164 | 529 | (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest)) |
d02c9bcd SM |
530 | ((eq 'or (caar matches)) |
531 | (let* ((alts (cdar matches)) | |
532 | (var (if (eq (caar alts) 'match) (cadr (car alts)))) | |
533 | (simples '()) (others '())) | |
534 | (when var | |
535 | (dolist (alt alts) | |
536 | (if (and (eq (car alt) 'match) (eq var (cadr alt)) | |
537 | (let ((upat (cddr alt))) | |
538 | (and (eq (car-safe upat) '\`) | |
dcc029e0 SM |
539 | (or (integerp (cadr upat)) (symbolp (cadr upat)) |
540 | (stringp (cadr upat)))))) | |
d02c9bcd SM |
541 | (push (cddr alt) simples) |
542 | (push alt others)))) | |
543 | (cond | |
872ab164 | 544 | ((null alts) (error "Please avoid it") (pcase--u rest)) |
d02c9bcd SM |
545 | ((> (length simples) 1) |
546 | ;; De-hoist the `or' MATCH into an `or' pattern that will be | |
547 | ;; turned into a `memq' below. | |
872ab164 SM |
548 | (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) |
549 | code vars | |
550 | (if (null others) rest | |
9a05edc4 | 551 | (cons (cons |
872ab164 SM |
552 | (pcase--and (if (cdr others) |
553 | (cons 'or (nreverse others)) | |
554 | (car others)) | |
555 | (cdr matches)) | |
9a05edc4 | 556 | (cons code vars)) |
872ab164 | 557 | rest)))) |
d02c9bcd | 558 | (t |
872ab164 SM |
559 | (pcase--u1 (cons (pop alts) (cdr matches)) code vars |
560 | (if (null alts) (progn (error "Please avoid it") rest) | |
9a05edc4 | 561 | (cons (cons |
872ab164 SM |
562 | (pcase--and (if (cdr alts) |
563 | (cons 'or alts) (car alts)) | |
564 | (cdr matches)) | |
9a05edc4 | 565 | (cons code vars)) |
872ab164 | 566 | rest))))))) |
d02c9bcd | 567 | ((eq 'match (caar matches)) |
9a05edc4 | 568 | (let* ((popmatches (pop matches)) |
d032d5e7 | 569 | (_op (car popmatches)) (cdrpopmatches (cdr popmatches)) |
9a05edc4 SM |
570 | (sym (car cdrpopmatches)) |
571 | (upat (cdr cdrpopmatches))) | |
d02c9bcd | 572 | (cond |
872ab164 SM |
573 | ((memq upat '(t _)) (pcase--u1 matches code vars rest)) |
574 | ((eq upat 'dontcare) :pcase--dontcare) | |
dcc029e0 | 575 | ((memq (car-safe upat) '(guard pred)) |
1f0816b6 | 576 | (if (eq (car upat) 'pred) (put sym 'pcase-used t)) |
9a05edc4 | 577 | (let* ((splitrest |
ca105506 | 578 | (pcase--split-rest |
ee4b1330 | 579 | sym (lambda (pat) (pcase--split-pred upat pat)) rest)) |
9a05edc4 SM |
580 | (then-rest (car splitrest)) |
581 | (else-rest (cdr splitrest))) | |
872ab164 SM |
582 | (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) |
583 | `(,(cadr upat) ,sym) | |
584 | (let* ((exp (cadr upat)) | |
585 | ;; `vs' is an upper bound on the vars we need. | |
586 | (vs (pcase--fgrep (mapcar #'car vars) exp)) | |
ca105506 SM |
587 | (env (mapcar (lambda (var) |
588 | (list var (cdr (assq var vars)))) | |
589 | vs)) | |
590 | (call (if (eq 'guard (car upat)) | |
591 | exp | |
592 | (when (memq sym vs) | |
593 | ;; `sym' is shadowed by `env'. | |
594 | (let ((newsym (make-symbol "x"))) | |
595 | (push (list newsym sym) env) | |
596 | (setq sym newsym))) | |
9abdc45d SM |
597 | (if (functionp exp) |
598 | `(funcall #',exp ,sym) | |
ca105506 | 599 | `(,@exp ,sym))))) |
872ab164 SM |
600 | (if (null vs) |
601 | call | |
602 | ;; Let's not replace `vars' in `exp' since it's | |
603 | ;; too difficult to do it right, instead just | |
604 | ;; let-bind `vars' around `exp'. | |
ca105506 | 605 | `(let* ,env ,call)))) |
872ab164 SM |
606 | (pcase--u1 matches code vars then-rest) |
607 | (pcase--u else-rest)))) | |
d02c9bcd | 608 | ((symbolp upat) |
1f0816b6 | 609 | (put sym 'pcase-used t) |
f9d554dd SM |
610 | (if (not (assq upat vars)) |
611 | (pcase--u1 matches code (cons (cons upat sym) vars) rest) | |
612 | ;; Non-linear pattern. Turn it into an `eq' test. | |
613 | (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) | |
614 | matches) | |
615 | code vars rest))) | |
ca105506 SM |
616 | ((eq (car-safe upat) 'let) |
617 | ;; A upat of the form (let VAR EXP). | |
618 | ;; (pcase--u1 matches code | |
619 | ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) | |
2ee3d7f0 | 620 | (macroexp-let2 |
4dd1c416 SM |
621 | macroexp-copyable-p sym |
622 | (let* ((exp (nth 2 upat)) | |
623 | (found (assq exp vars))) | |
624 | (if found (cdr found) | |
625 | (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) | |
626 | (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) | |
627 | vs))) | |
628 | (if env (macroexp-let* env exp) exp)))) | |
629 | (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) | |
630 | code vars rest))) | |
d02c9bcd | 631 | ((eq (car-safe upat) '\`) |
1f0816b6 | 632 | (put sym 'pcase-used t) |
872ab164 | 633 | (pcase--q1 sym (cadr upat) matches code vars rest)) |
d02c9bcd | 634 | ((eq (car-safe upat) 'or) |
dcc029e0 SM |
635 | (let ((all (> (length (cdr upat)) 1)) |
636 | (memq-fine t)) | |
d02c9bcd SM |
637 | (when all |
638 | (dolist (alt (cdr upat)) | |
639 | (unless (and (eq (car-safe alt) '\`) | |
dcc029e0 SM |
640 | (or (symbolp (cadr alt)) (integerp (cadr alt)) |
641 | (setq memq-fine nil) | |
642 | (stringp (cadr alt)))) | |
d02c9bcd SM |
643 | (setq all nil)))) |
644 | (if all | |
645 | ;; Use memq for (or `a `b `c `d) rather than a big tree. | |
9a05edc4 SM |
646 | (let* ((elems (mapcar 'cadr (cdr upat))) |
647 | (splitrest | |
648 | (pcase--split-rest | |
ee4b1330 | 649 | sym (lambda (pat) (pcase--split-member elems pat)) rest)) |
9a05edc4 SM |
650 | (then-rest (car splitrest)) |
651 | (else-rest (cdr splitrest))) | |
6876a58d | 652 | (put sym 'pcase-used t) |
9a05edc4 SM |
653 | (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) |
654 | (pcase--u1 matches code vars then-rest) | |
655 | (pcase--u else-rest))) | |
872ab164 SM |
656 | (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars |
657 | (append (mapcar (lambda (upat) | |
658 | `((and (match ,sym . ,upat) ,@matches) | |
659 | ,code ,@vars)) | |
660 | (cddr upat)) | |
661 | rest))))) | |
d02c9bcd | 662 | ((eq (car-safe upat) 'and) |
872ab164 SM |
663 | (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) |
664 | (cdr upat)) | |
665 | matches) | |
666 | code vars rest)) | |
d02c9bcd SM |
667 | ((eq (car-safe upat) 'not) |
668 | ;; FIXME: The implementation below is naive and results in | |
669 | ;; inefficient code. | |
872ab164 | 670 | ;; To make it work right, we would need to turn pcase--u1's |
d02c9bcd SM |
671 | ;; `code' and `vars' into a single argument of the same form as |
672 | ;; `rest'. We would also need to split this new `then-rest' argument | |
673 | ;; for every test (currently we don't bother to do it since | |
674 | ;; it's only useful for odd patterns like (and `(PAT1 . PAT2) | |
675 | ;; `(PAT3 . PAT4)) which the programmer can easily rewrite | |
676 | ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). | |
872ab164 | 677 | (pcase--u1 `((match ,sym . ,(cadr upat))) |
94d11cb5 IK |
678 | ;; FIXME: This codegen is not careful to share its |
679 | ;; code if used several times: code blow up is likely. | |
d032d5e7 | 680 | (lambda (_vars) |
94d11cb5 IK |
681 | ;; `vars' will likely contain bindings which are |
682 | ;; not always available in other paths to | |
683 | ;; `rest', so there' no point trying to pass | |
684 | ;; them down. | |
685 | (pcase--u rest)) | |
872ab164 SM |
686 | vars |
687 | (list `((and . ,matches) ,code . ,vars)))) | |
d02c9bcd SM |
688 | (t (error "Unknown upattern `%s'" upat))))) |
689 | (t (error "Incorrect MATCH %s" (car matches))))) | |
690 | ||
872ab164 | 691 | (defun pcase--q1 (sym qpat matches code vars rest) |
d02c9bcd | 692 | "Return code that runs CODE if SYM matches QPAT and if MATCHES match. |
ca3afb79 | 693 | Otherwise, it defers to REST which is a list of branches of the form |
d02c9bcd SM |
694 | \(OTHER_MATCH OTHER-CODE . OTHER-VARS)." |
695 | (cond | |
696 | ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) | |
697 | ((floatp qpat) (error "Floating point patterns not supported")) | |
698 | ((vectorp qpat) | |
699 | ;; FIXME. | |
700 | (error "Vector QPatterns not implemented yet")) | |
701 | ((consp qpat) | |
0d6459df SM |
702 | (let* ((syma (make-symbol "xcar")) |
703 | (symd (make-symbol "xcdr")) | |
704 | (splitrest (pcase--split-rest | |
705 | sym | |
ee4b1330 | 706 | (lambda (pat) (pcase--split-consp syma symd pat)) |
0d6459df SM |
707 | rest)) |
708 | (then-rest (car splitrest)) | |
709 | (else-rest (cdr splitrest)) | |
710 | (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) | |
711 | (match ,symd . ,(pcase--upat (cdr qpat))) | |
712 | ,@matches) | |
713 | code vars then-rest))) | |
714 | (pcase--if | |
715 | `(consp ,sym) | |
716 | ;; We want to be careful to only add bindings that are used. | |
717 | ;; The byte-compiler could do that for us, but it would have to pay | |
718 | ;; attention to the `consp' test in order to figure out that car/cdr | |
719 | ;; can't signal errors and our byte-compiler is not that clever. | |
5342bb06 SM |
720 | ;; FIXME: Some of those let bindings occur too early (they are used in |
721 | ;; `then-body', but only within some sub-branch). | |
4dd1c416 | 722 | (macroexp-let* |
5342bb06 | 723 | `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) |
0d6459df | 724 | ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) |
5342bb06 | 725 | then-body) |
0d6459df | 726 | (pcase--u else-rest)))) |
dcc029e0 | 727 | ((or (integerp qpat) (symbolp qpat) (stringp qpat)) |
9a05edc4 | 728 | (let* ((splitrest (pcase--split-rest |
ee4b1330 | 729 | sym (lambda (pat) (pcase--split-equal qpat pat)) rest)) |
9a05edc4 SM |
730 | (then-rest (car splitrest)) |
731 | (else-rest (cdr splitrest))) | |
5342bb06 SM |
732 | (pcase--if (cond |
733 | ((stringp qpat) `(equal ,sym ,qpat)) | |
734 | ((null qpat) `(null ,sym)) | |
735 | (t `(eq ,sym ',qpat))) | |
872ab164 SM |
736 | (pcase--u1 matches code vars then-rest) |
737 | (pcase--u else-rest)))) | |
22bcf204 | 738 | (t (error "Unknown QPattern %s" qpat)))) |
97eedd1b | 739 | |
d02c9bcd SM |
740 | |
741 | (provide 'pcase) | |
742 | ;;; pcase.el ends here |