* lisp/emacs-lisp/package.el (package-selected-packages): Fix doc
[emacs.git] / lisp / emacs-lisp / pcase.el
Commit [+]AuthorDateLineData
513749ee Stefan Monnier2012-06-08 09:18:26 -04001;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +02002
7e09ef09 Paul Eggert2015-01-01 14:26:41 -08003;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +02004
5;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
ca3afb79 Juanma Barranquero2011-02-28 05:24:40 +01006;; Keywords:
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +02007
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
Stefan Monnier2010-10-28 21:05:38 -040028;; Todo:
29
ca105506
SM
Stefan Monnier2011-03-16 16:08:39 -040030;; - (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
Stefan Monnier2010-10-28 21:05:38 -040034;; - 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 Stefan Monnier2010-11-24 11:39:51 -050038;; extension provide its own `pcase--split-<foo>' thingy.
ca105506 Stefan Monnier2011-03-16 16:08:39 -040039;; - along these lines, provide patterns to match CL structs.
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -050040;; - provide something like (setq VAR) so a var can be set rather than
41;; let-bound.
a179e3f7
SM
Stefan Monnier2012-05-26 11:52:27 -040042;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
43;; this :-()
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -050044;; - try and be more clever to reduce the size of the decision tree, and
ca105506 Stefan Monnier2011-03-16 16:08:39 -040045;; to reduce the number of leaves that need to be turned into function:
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -050046;; - first, do the tests shared by all remaining branches (it will have
a179e3f7 Stefan Monnier2012-05-26 11:52:27 -040047;; to be performed anyway, so better do it first so it's shared).
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -050048;; - then choose the test that discriminates more (?).
a179e3f7
SM
Stefan Monnier2012-05-26 11:52:27 -040049;; - provide Agda's `with' (along with its `...' companion).
50;; - implement (not UPAT). This might require a significant redesign.
dcc029e0
SM
Stefan Monnier2010-10-28 21:05:38 -040051;; - 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
Stefan Monnier2010-08-10 15:18:14 +020054;;; Code:
55
4dd1c416
SM
Stefan Monnier2012-06-07 15:25:48 -040056(require 'macroexp)
57
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +020058;; 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.
972debf2
SM
Stefan Monnier2012-09-04 13:40:25 -040063;; FIXME: Now that macroexpansion is also performed when loading an interpreted
64;; file, this is not a real problem any more.
e2abe5a1 Stefan Monnier2011-03-05 23:48:17 -050065(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -040066;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
67;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +020068
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -040069(defconst pcase--dontcare-upats '(t _ pcase--dontcare))
872ab164 Stefan Monnier2010-11-24 11:39:51 -050070
85b3d352
LL
Leo Liu2014-09-14 00:30:21 +080071(defvar pcase--dontwarn-upats '(pcase--dontcare))
72
a4712e11
JB
Johan Bockgård2012-06-10 20:46:21 -040073(def-edebug-spec
74 pcase-UPAT
75 (&or symbolp
76 ("or" &rest pcase-UPAT)
77 ("and" &rest pcase-UPAT)
a4712e11
JB
Johan Bockgård2012-06-10 20:46:21 -040078 ("guard" form)
79 ("let" pcase-UPAT form)
66a53da5
JB
Johan Bockgård2015-04-12 16:26:51 +020080 ("pred" pcase-FUN)
81 ("app" pcase-FUN pcase-UPAT)
2e47de36 Johan Bockgård2015-04-12 16:26:52 +020082 pcase-MACRO
66a53da5
JB
Johan Bockgård2015-04-12 16:26:51 +020083 sexp))
84
85(def-edebug-spec
86 pcase-FUN
87 (&or lambda-expr
88 ;; Punt on macros/special forms.
89 (functionp &rest form)
a4712e11
JB
Johan Bockgård2012-06-10 20:46:21 -040090 sexp))
91
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +020092(def-edebug-spec pcase-MACRO pcase--edebug-match-macro)
93
a73af965
GM
Glenn Morris2015-05-01 13:40:31 -040094;; Only called from edebug.
95(declare-function get-edebug-spec "edebug" (symbol))
96(declare-function edebug-match "edebug" (cursor specs))
97
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +020098(defun pcase--edebug-match-macro (cursor)
99 (let (specs)
100 (mapatoms
101 (lambda (s)
102 (let ((m (get s 'pcase-macroexpander)))
103 (when (and m (get-edebug-spec m))
104 (push (cons (symbol-name s) (get-edebug-spec m))
105 specs)))))
106 (edebug-match cursor (cons '&or specs))))
107
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200108;;;###autoload
109(defmacro pcase (exp &rest cases)
110 "Perform ML-style pattern matching on EXP.
111CASES is a list of elements of the form (UPATTERN CODE...).
112
113UPatterns can take the following forms:
114 _ matches anything.
19faa8e8 Stefan Monnier2012-07-10 05:26:04 -0400115 SELFQUOTING matches itself. This includes keywords, numbers, and strings.
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200116 SYMBOL matches anything and binds it to SYMBOL.
117 (or UPAT...) matches if any of the patterns matches.
118 (and UPAT...) matches if all the patterns match.
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400119 'VAL matches if the object is `equal' to VAL
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400120 (pred FUN) matches if FUN applied to the object returns non-nil.
dcc029e0 Stefan Monnier2010-10-28 21:05:38 -0400121 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400122 (let UPAT EXP) matches if EXP matches UPAT.
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400123 (app FUN UPAT) matches if FUN applied to the object matches UPAT.
f9d554dd
SM
Stefan Monnier2011-02-17 23:58:21 -0500124If a SYMBOL is used twice in the same pattern (i.e. the pattern is
125\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200126
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400127FUN can take the form
128 SYMBOL or (lambda ARGS BODY) in which case it's called with one argument.
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400129 (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
7abaf5cc Stefan Monnier2012-07-25 21:27:33 -0400130 which is the value being matched.
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400131So a FUN of the form SYMBOL is equivalent to one of the form (FUN).
132FUN can refer to variables bound earlier in the pattern.
133FUN is assumed to be pure, i.e. it can be dropped if its result is not used,
134and two identical calls can be merged into one.
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200135E.g. you can match pairs where the cdr is larger than the car with a pattern
136like `(,a . ,(pred (< a))) or, with more checks:
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400137`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))
138
139Additional patterns can be defined via `pcase-defmacro'.
140Currently, the following patterns are provided this way:"
a4712e11 Johan Bockgård2012-06-10 20:46:21 -0400141 (declare (indent 1) (debug (form &rest (pcase-UPAT body))))
e2abe5a1
SM
Stefan Monnier2011-03-05 23:48:17 -0500142 ;; We want to use a weak hash table as a cache, but the key will unavoidably
143 ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
144 ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
145 ;; which does come straight from the source code and should hence not be GC'd
146 ;; so easily.
147 (let ((data (gethash (car cases) pcase--memoize)))
148 ;; data = (EXP CASES . EXPANSION)
149 (if (and (equal exp (car data)) (equal cases (cadr data)))
150 ;; We have the right expansion.
151 (cddr data)
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400152 ;; (when (gethash (car cases) pcase--memoize-1)
153 ;; (message "pcase-memoize failed because of weak key!!"))
154 ;; (when (gethash (car cases) pcase--memoize-2)
155 ;; (message "pcase-memoize failed because of eq test on %S"
156 ;; (car cases)))
e2abe5a1
SM
Stefan Monnier2011-03-05 23:48:17 -0500157 (when data
158 (message "pcase-memoize: equal first branch, yet different"))
159 (let ((expansion (pcase--expand exp cases)))
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400160 (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
161 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
162 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
e2abe5a1 Stefan Monnier2011-03-05 23:48:17 -0500163 expansion))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200164
a73af965
GM
Glenn Morris2015-05-01 13:40:31 -0400165(declare-function help-fns--signature "help-fns"
166 (function doc real-def real-function))
167
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400168;; FIXME: Obviously, this will collide with nadvice's use of
169;; function-documentation if we happen to advise `pcase'.
170(put 'pcase 'function-documentation '(pcase--make-docstring))
171(defun pcase--make-docstring ()
172 (let* ((main (documentation (symbol-function 'pcase) 'raw))
173 (ud (help-split-fundoc main 'pcase)))
d6b91bf5
GM
Glenn Morris2015-05-01 13:39:23 -0400174 ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
175 ;; where cl-lib is anything using pcase-defmacro.
176 (require 'help-fns)
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400177 (with-temp-buffer
178 (insert (or (cdr ud) main))
179 (mapatoms
180 (lambda (symbol)
181 (let ((me (get symbol 'pcase-macroexpander)))
182 (when me
183 (insert "\n\n-- ")
184 (let* ((doc (documentation me 'raw)))
185 (setq doc (help-fns--signature symbol doc me
186 (indirect-function me)))
187 (insert "\n" (or doc "Not documented.")))))))
188 (let ((combined-doc (buffer-string)))
189 (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
190
85b3d352
LL
Leo Liu2014-09-14 00:30:21 +0800191;;;###autoload
192(defmacro pcase-exhaustive (exp &rest cases)
193 "The exhaustive version of `pcase' (which see)."
194 (declare (indent 1) (debug pcase))
195 (let* ((x (make-symbol "x"))
196 (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
197 (pcase--expand
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400198 ;; FIXME: Could we add the FILE:LINE data in the error message?
85b3d352
LL
Leo Liu2014-09-14 00:30:21 +0800199 exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
200
751adc4b
LL
Leo Liu2015-02-09 10:05:44 +0800201;;;###autoload
202(defmacro pcase-lambda (lambda-list &rest body)
8aa13d07
SM
Stefan Monnier2015-03-19 13:46:36 -0400203 "Like `lambda' but allow each argument to be a UPattern.
204I.e. accepts the usual &optional and &rest keywords, but every
205formal argument can be any pattern accepted by `pcase' (a mere
206variable name being but a special case of it)."
751adc4b Leo Liu2015-02-09 10:05:44 +0800207 (declare (doc-string 2) (indent defun)
8aa13d07
SM
Stefan Monnier2015-03-19 13:46:36 -0400208 (debug ((&rest pcase-UPAT) body)))
209 (let* ((bindings ())
210 (parsed-body (macroexp-parse-body body))
211 (args (mapcar (lambda (pat)
212 (if (symbolp pat)
213 ;; Simple vars and &rest/&optional are just passed
214 ;; through unchanged.
215 pat
216 (let ((arg (make-symbol
217 (format "arg%s" (length bindings)))))
218 (push `(,pat ,arg) bindings)
219 arg)))
220 lambda-list)))
221 `(lambda ,args ,@(car parsed-body)
222 (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
751adc4b Leo Liu2015-02-09 10:05:44 +0800223
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400224(defun pcase--let* (bindings body)
225 (cond
226 ((null bindings) (macroexp-progn body))
227 ((pcase--trivial-upat-p (caar bindings))
228 (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
229 (t
230 (let ((binding (pop bindings)))
231 (pcase--expand
232 (cadr binding)
233 `((,(car binding) ,(pcase--let* bindings body))
a464a6c7
SM
Stefan Monnier2012-07-11 19:13:41 -0400234 ;; We can either signal an error here, or just use `pcase--dontcare'
235 ;; which generates more efficient code. In practice, if we use
236 ;; `pcase--dontcare' we will still often get an error and the few
237 ;; cases where we don't do not matter that much, so
238 ;; it's a better choice.
239 (pcase--dontcare nil)))))))
82ad98e3 Stefan Monnier2012-06-10 20:33:33 -0400240
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200241;;;###autoload
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500242(defmacro pcase-let* (bindings &rest body)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200243 "Like `let*' but where you can use `pcase' patterns for bindings.
244BODY should be an expression, and BINDINGS should be a list of bindings
245of the form (UPAT EXP)."
c41045e6 Stefan Monnier2012-05-15 14:45:27 -0400246 (declare (indent 1)
a4712e11 Johan Bockgård2012-06-10 20:46:21 -0400247 (debug ((&rest (pcase-UPAT &optional form)) body)))
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400248 (let ((cached (gethash bindings pcase--memoize)))
249 ;; cached = (BODY . EXPANSION)
250 (if (equal (car cached) body)
251 (cdr cached)
252 (let ((expansion (pcase--let* bindings body)))
253 (puthash bindings (cons body expansion) pcase--memoize)
254 expansion))))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200255
256;;;###autoload
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500257(defmacro pcase-let (bindings &rest body)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200258 "Like `let' but where you can use `pcase' patterns for bindings.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500259BODY should be a list of expressions, and BINDINGS should be a list of bindings
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200260of the form (UPAT EXP)."
c41045e6 Stefan Monnier2012-05-15 14:45:27 -0400261 (declare (indent 1) (debug pcase-let*))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200262 (if (null (cdr bindings))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500263 `(pcase-let* ,bindings ,@body)
264 (let ((matches '()))
265 (dolist (binding (prog1 bindings (setq bindings nil)))
266 (cond
267 ((memq (car binding) pcase--dontcare-upats)
268 (push (cons (make-symbol "_") (cdr binding)) bindings))
269 ((pcase--trivial-upat-p (car binding)) (push binding bindings))
270 (t
271 (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
272 (push (cons tmpvar (cdr binding)) bindings)
273 (push (list (car binding) tmpvar) matches)))))
274 `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
275
4aca2fdf Stefan Monnier2015-04-13 14:46:58 -0400276;;;###autoload
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500277(defmacro pcase-dolist (spec &rest body)
a4712e11 Johan Bockgård2012-06-10 20:46:21 -0400278 (declare (indent 1) (debug ((pcase-UPAT form) body)))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500279 (if (pcase--trivial-upat-p (car spec))
280 `(dolist ,spec ,@body)
281 (let ((tmpvar (make-symbol "x")))
282 `(dolist (,tmpvar ,@(cdr spec))
283 (pcase-let* ((,(car spec) ,tmpvar))
284 ,@body)))))
285
286
287(defun pcase--trivial-upat-p (upat)
288 (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
289
290(defun pcase--expand (exp cases)
e2abe5a1
SM
Stefan Monnier2011-03-05 23:48:17 -0500291 ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
292 ;; (emacs-pid) exp (sxhash cases))
2ee3d7f0 Stefan Monnier2012-06-22 09:42:38 -0400293 (macroexp-let2 macroexp-copyable-p val exp
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400294 (let* ((defs ())
295 (seen '())
296 (codegen
297 (lambda (code vars)
298 (let ((prev (assq code seen)))
299 (if (not prev)
300 (let ((res (pcase-codegen code vars)))
301 (push (list code vars res) seen)
302 res)
303 ;; Since we use a tree-based pattern matching
304 ;; technique, the leaves (the places that contain the
305 ;; code to run once a pattern is matched) can get
306 ;; copied a very large number of times, so to avoid
307 ;; code explosion, we need to keep track of how many
308 ;; times we've used each leaf and move it
309 ;; to a separate function if that number is too high.
310 ;;
311 ;; We've already used this branch. So it is shared.
312 (let* ((code (car prev)) (cdrprev (cdr prev))
313 (prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
314 (res (car cddrprev)))
315 (unless (symbolp res)
316 ;; This is the first repeat, so we have to move
317 ;; the branch to a separate function.
318 (let ((bsym
319 (make-symbol (format "pcase-%d" (length defs)))))
ee4b1330
SM
Stefan Monnier2012-06-18 15:23:35 -0400320 (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code))
321 defs)
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400322 (setcar res 'funcall)
323 (setcdr res (cons bsym (mapcar #'cdr prevvars)))
324 (setcar (cddr prev) bsym)
325 (setq res bsym)))
326 (setq vars (copy-sequence vars))
327 (let ((args (mapcar (lambda (pa)
328 (let ((v (assq (car pa) vars)))
329 (setq vars (delq v vars))
330 (cdr v)))
331 prevvars)))
332 ;; If some of `vars' were not found in `prevvars', that's
333 ;; OK it just means those vars aren't present in all
334 ;; branches, so they can be used within the pattern
335 ;; (e.g. by a `guard/let/pred') but not in the branch.
336 ;; FIXME: But if some of `prevvars' are not in `vars' we
337 ;; should remove them from `prevvars'!
338 `(funcall ,res ,@args)))))))
ee4b1330 Stefan Monnier2012-06-18 15:23:35 -0400339 (used-cases ())
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400340 (main
341 (pcase--u
342 (mapcar (lambda (case)
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400343 `(,(pcase--match val (pcase--macroexpand (car case)))
ee4b1330
SM
Stefan Monnier2012-06-18 15:23:35 -0400344 ,(lambda (vars)
345 (unless (memq case used-cases)
346 ;; Keep track of the cases that are used.
347 (push case used-cases))
348 (funcall
349 (if (pcase--small-branch-p (cdr case))
350 ;; Don't bother sharing multiple
351 ;; occurrences of this leaf since it's small.
352 #'pcase-codegen codegen)
353 (cdr case)
354 vars))))
82ad98e3 Stefan Monnier2012-06-10 20:33:33 -0400355 cases))))
ee4b1330 Stefan Monnier2012-06-18 15:23:35 -0400356 (dolist (case cases)
85b3d352
LL
Leo Liu2014-09-14 00:30:21 +0800357 (unless (or (memq case used-cases)
358 (memq (car case) pcase--dontwarn-upats))
ee4b1330 Stefan Monnier2012-06-18 15:23:35 -0400359 (message "Redundant pcase pattern: %S" (car case))))
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400360 (macroexp-let* defs main))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200361
536cda1f
SM
Stefan Monnier2014-09-22 11:04:12 -0400362(defun pcase--macroexpand (pat)
363 "Expands all macro-patterns in PAT."
364 (let ((head (car-safe pat)))
365 (cond
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400366 ((null head)
367 (if (pcase--self-quoting-p pat) `',pat pat))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400368 ((memq head '(pred guard quote)) pat)
536cda1f
SM
Stefan Monnier2014-09-22 11:04:12 -0400369 ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
370 ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
371 ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
372 (t
373 (let* ((expander (get head 'pcase-macroexpander))
374 (npat (if expander (apply expander (cdr pat)))))
375 (if (null npat)
376 (error (if expander
377 "Unexpandable %s pattern: %S"
378 "Unknown %s pattern: %S")
379 head pat)
380 (pcase--macroexpand npat)))))))
381
382;;;###autoload
383(defmacro pcase-defmacro (name args &rest body)
384 "Define a pcase UPattern macro."
ae277259 Stefan Monnier2015-03-23 18:24:30 -0400385 (declare (indent 2) (debug defun) (doc-string 3))
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +0200386 ;; Add the function via `fsym', so that an autoload cookie placed
387 ;; on a pcase-defmacro will cause the macro to be loaded on demand.
388 (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
389 (decl (assq 'declare body)))
390 (when decl (setq body (remove decl body)))
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400391 `(progn
392 (defun ,fsym ,args ,@body)
2e47de36 Johan Bockgård2015-04-12 16:26:52 +0200393 (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
ae277259 Stefan Monnier2015-03-23 18:24:30 -0400394 (put ',name 'pcase-macroexpander #',fsym))))
536cda1f Stefan Monnier2014-09-22 11:04:12 -0400395
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400396(defun pcase--match (val upat)
397 "Build a MATCH structure, hoisting all `or's and `and's outside."
398 (cond
399 ;; Hoist or/and patterns into or/and matches.
400 ((memq (car-safe upat) '(or and))
401 `(,(car upat)
402 ,@(mapcar (lambda (upat)
403 (pcase--match val upat))
404 (cdr upat))))
405 (t
406 `(match ,val . ,upat))))
407
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200408(defun pcase-codegen (code vars)
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400409 ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
6876a58d
SM
Stefan Monnier2012-05-29 10:28:02 -0400410 ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
411 ;; codegen from later metamorphosing this let into a funcall.
412 `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200413 ,@code))
414
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500415(defun pcase--small-branch-p (code)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200416 (and (= 1 (length code))
417 (or (not (consp (car code)))
418 (let ((small t))
419 (dolist (e (car code))
420 (if (consp e) (setq small nil)))
421 small))))
422
423;; Try to use `cond' rather than a sequence of `if's, so as to reduce
424;; the depth of the generated tree.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500425(defun pcase--if (test then else)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200426 (cond
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500427 ((eq else :pcase--dontcare) then)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500428 ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400429 (t (macroexp-if test then else))))
5342bb06 Stefan Monnier2012-05-04 22:05:49 -0400430
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200431;; Note about MATCH:
432;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
433;; check, we want to turn all the similar patterns into ones of the form
434;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
435;; Earlier code hence used branches of the form (MATCHES . CODE) where
436;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
437;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
438;; no easy way to eliminate the `consp' check in such a representation.
439;; So we replaced the MATCHES by the MATCH below which can be made up
440;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
441;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
442;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
443;; The downside is that we now have `or' and `and' both in MATCH and
444;; in PAT, so there are different equivalent representations and we
445;; need to handle them all. We do not try to systematically
446;; canonicalize them to one form over another, but we do occasionally
447;; turn one into the other.
448
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500449(defun pcase--u (branches)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200450 "Expand matcher for rules BRANCHES.
451Each BRANCH has the form (MATCH CODE . VARS) where
452CODE is the code generator for that branch.
453VARS is the set of vars already bound by earlier matches.
454MATCH is the pattern that needs to be matched, of the form:
455 (match VAR . UPAT)
456 (and MATCH ...)
457 (or MATCH ...)"
458 (when (setq branches (delq nil branches))
9a05edc4
SM
Stefan Monnier2011-02-18 08:55:51 -0500459 (let* ((carbranch (car branches))
460 (match (car carbranch)) (cdarbranch (cdr carbranch))
461 (code (car cdarbranch))
462 (vars (cdr cdarbranch)))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500463 (pcase--u1 (list match) code vars (cdr branches)))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200464
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500465(defun pcase--and (match matches)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200466 (if matches `(and ,match ,@matches) match))
467
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500468(defconst pcase-mutually-exclusive-predicates
469 '((symbolp . integerp)
470 (symbolp . numberp)
471 (symbolp . consp)
472 (symbolp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400473 (symbolp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500474 (symbolp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400475 (symbolp . byte-code-function-p)
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500476 (integerp . consp)
477 (integerp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400478 (integerp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500479 (integerp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400480 (integerp . byte-code-function-p)
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500481 (numberp . consp)
482 (numberp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400483 (numberp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500484 (numberp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400485 (numberp . byte-code-function-p)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500486 (consp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400487 (consp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500488 (consp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400489 (consp . byte-code-function-p)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400490 (arrayp . byte-code-function-p)
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400491 (vectorp . byte-code-function-p)
492 (stringp . vectorp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400493 (stringp . byte-code-function-p)))
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500494
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400495(defun pcase--mutually-exclusive-p (pred1 pred2)
496 (or (member (cons pred1 pred2)
497 pcase-mutually-exclusive-predicates)
498 (member (cons pred2 pred1)
499 pcase-mutually-exclusive-predicates)))
500
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500501(defun pcase--split-match (sym splitter match)
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500502 (cond
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400503 ((eq (car-safe match) 'match)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200504 (if (not (eq sym (cadr match)))
505 (cons match match)
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400506 (let ((res (funcall splitter (cddr match))))
507 (cons (or (car res) match) (or (cdr res) match)))))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400508 ((memq (car-safe match) '(or and))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200509 (let ((then-alts '())
510 (else-alts '())
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500511 (neutral-elem (if (eq 'or (car match))
512 :pcase--fail :pcase--succeed))
513 (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200514 (dolist (alt (cdr match))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500515 (let ((split (pcase--split-match sym splitter alt)))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200516 (unless (eq (car split) neutral-elem)
517 (push (car split) then-alts))
518 (unless (eq (cdr split) neutral-elem)
519 (push (cdr split) else-alts))))
520 (cons (cond ((memq zero-elem then-alts) zero-elem)
521 ((null then-alts) neutral-elem)
522 ((null (cdr then-alts)) (car then-alts))
523 (t (cons (car match) (nreverse then-alts))))
524 (cond ((memq zero-elem else-alts) zero-elem)
525 ((null else-alts) neutral-elem)
526 ((null (cdr else-alts)) (car else-alts))
527 (t (cons (car match) (nreverse else-alts)))))))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400528 ((memq match '(:pcase--succeed :pcase--fail)) (cons match match))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200529 (t (error "Uknown MATCH %s" match))))
530
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500531(defun pcase--split-rest (sym splitter rest)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200532 (let ((then-rest '())
533 (else-rest '()))
534 (dolist (branch rest)
535 (let* ((match (car branch))
536 (code&vars (cdr branch))
bbd240ce Paul Eggert2011-12-14 23:24:10 -0800537 (split
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500538 (pcase--split-match sym splitter match)))
bbd240ce
PE
Paul Eggert2011-12-14 23:24:10 -0800539 (unless (eq (car split) :pcase--fail)
540 (push (cons (car split) code&vars) then-rest))
541 (unless (eq (cdr split) :pcase--fail)
542 (push (cons (cdr split) code&vars) else-rest))))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200543 (cons (nreverse then-rest) (nreverse else-rest))))
544
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500545(defun pcase--split-equal (elem pat)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200546 (cond
547 ;; The same match will give the same result.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400548 ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500549 '(:pcase--succeed . :pcase--fail))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200550 ;; A different match will fail if this one succeeds.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400551 ((and (eq (car-safe pat) 'quote)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200552 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
553 ;; (consp (cadr pat)))
554 )
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500555 '(:pcase--fail . nil))
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500556 ((and (eq (car-safe pat) 'pred)
557 (symbolp (cadr pat))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500558 (get (cadr pat) 'side-effect-free))
6f547583
SM
Stefan Monnier2014-01-02 23:40:30 -0500559 (ignore-errors
560 (if (funcall (cadr pat) elem)
561 '(:pcase--succeed . nil)
562 '(:pcase--fail . nil))))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200563
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500564(defun pcase--split-member (elems pat)
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400565 ;; FIXME: The new pred-based member code doesn't do these optimizations!
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500566 ;; Based on pcase--split-equal.
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200567 (cond
dcc029e0
SM
Stefan Monnier2010-10-28 21:05:38 -0400568 ;; The same match (or a match of membership in a superset) will
569 ;; give the same result, but we don't know how to check it.
4de81ee0 Stefan Monnier2010-09-01 12:03:08 +0200570 ;; (???
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500571 ;; '(:pcase--succeed . nil))
4de81ee0 Stefan Monnier2010-09-01 12:03:08 +0200572 ;; A match for one of the elements may succeed or fail.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400573 ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
4de81ee0 Stefan Monnier2010-09-01 12:03:08 +0200574 nil)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200575 ;; A different match will fail if this one succeeds.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400576 ((and (eq (car-safe pat) 'quote)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200577 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
578 ;; (consp (cadr pat)))
579 )
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500580 '(:pcase--fail . nil))
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500581 ((and (eq (car-safe pat) 'pred)
582 (symbolp (cadr pat))
583 (get (cadr pat) 'side-effect-free)
6f547583
SM
Stefan Monnier2014-01-02 23:40:30 -0500584 (ignore-errors
585 (let ((p (cadr pat)) (all t))
586 (dolist (elem elems)
587 (unless (funcall p elem) (setq all nil)))
588 all)))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500589 '(:pcase--succeed . nil))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200590
0b64b838 Stefan Monnier2013-07-08 17:54:54 -0400591(defun pcase--split-pred (vars upat pat)
5342bb06
SM
Stefan Monnier2012-05-04 22:05:49 -0400592 (let (test)
593 (cond
0b64b838
SM
Stefan Monnier2013-07-08 17:54:54 -0400594 ((and (equal upat pat)
595 ;; For predicates like (pred (> a)), two such predicates may
596 ;; actually refer to different variables `a'.
597 (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
598 ;; FIXME: `vars' gives us the environment in which `upat' will
599 ;; run, but we don't have the environment in which `pat' will
600 ;; run, so we can't do a reliable verification. But let's try
601 ;; and catch at least the easy cases such as (bug#14773).
602 (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
603 '(:pcase--succeed . :pcase--fail))
5342bb06 Stefan Monnier2012-05-04 22:05:49 -0400604 ((and (eq 'pred (car upat))
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400605 (let ((otherpred
606 (cond ((eq 'pred (car-safe pat)) (cadr pat))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400607 ((not (eq 'quote (car-safe pat))) nil)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400608 ((consp (cadr pat)) #'consp)
d7d72624 Stefan Monnier2015-03-23 23:40:06 -0400609 ((stringp (cadr pat)) #'stringp)
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400610 ((vectorp (cadr pat)) #'vectorp)
611 ((byte-code-function-p (cadr pat))
612 #'byte-code-function-p))))
613 (pcase--mutually-exclusive-p (cadr upat) otherpred)))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500614 '(:pcase--fail . nil))
5342bb06 Stefan Monnier2012-05-04 22:05:49 -0400615 ((and (eq 'pred (car upat))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400616 (eq 'quote (car-safe pat))
5342bb06
SM
Stefan Monnier2012-05-04 22:05:49 -0400617 (symbolp (cadr upat))
618 (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
619 (get (cadr upat) 'side-effect-free)
620 (ignore-errors
621 (setq test (list (funcall (cadr upat) (cadr pat))))))
622 (if (car test)
4bdc3526
SM
Stefan Monnier2013-01-08 17:26:21 -0500623 '(nil . :pcase--fail)
624 '(:pcase--fail . nil))))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200625
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500626(defun pcase--fgrep (vars sexp)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200627 "Check which of the symbols VARS appear in SEXP."
628 (let ((res '()))
629 (while (consp sexp)
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500630 (dolist (var (pcase--fgrep vars (pop sexp)))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200631 (unless (memq var res) (push var res))))
632 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
633 res))
634
19faa8e8
SM
Stefan Monnier2012-07-10 05:26:04 -0400635(defun pcase--self-quoting-p (upat)
636 (or (keywordp upat) (numberp upat) (stringp upat)))
637
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400638(defun pcase--app-subst-match (match sym fun nsym)
639 (cond
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400640 ((eq (car-safe match) 'match)
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400641 (if (and (eq sym (cadr match))
642 (eq 'app (car-safe (cddr match)))
643 (equal fun (nth 1 (cddr match))))
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400644 (pcase--match nsym (nth 2 (cddr match)))
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400645 match))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400646 ((memq (car-safe match) '(or and))
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400647 `(,(car match)
648 ,@(mapcar (lambda (match)
649 (pcase--app-subst-match match sym fun nsym))
650 (cdr match))))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400651 ((memq match '(:pcase--succeed :pcase--fail)) match)
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400652 (t (error "Uknown MATCH %s" match))))
653
654(defun pcase--app-subst-rest (rest sym fun nsym)
655 (mapcar (lambda (branch)
656 `(,(pcase--app-subst-match (car branch) sym fun nsym)
657 ,@(cdr branch)))
658 rest))
659
7f457c06
SM
Stefan Monnier2012-09-28 08:18:38 -0400660(defsubst pcase--mark-used (sym)
661 ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
662 (if (symbolp sym) (put sym 'pcase-used t)))
663
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400664(defmacro pcase--flip (fun arg1 arg2)
665 "Helper function, used internally to avoid (funcall (lambda ...) ...)."
666 (declare (debug (sexp body)))
667 `(,fun ,arg2 ,arg1))
668
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400669(defun pcase--funcall (fun arg vars)
670 "Build a function call to FUN with arg ARG."
671 (if (symbolp fun)
672 `(,fun ,arg)
673 (let* (;; `vs' is an upper bound on the vars we need.
674 (vs (pcase--fgrep (mapcar #'car vars) fun))
675 (env (mapcar (lambda (var)
676 (list var (cdr (assq var vars))))
677 vs))
678 (call (progn
679 (when (memq arg vs)
680 ;; `arg' is shadowed by `env'.
681 (let ((newsym (make-symbol "x")))
682 (push (list newsym arg) env)
683 (setq arg newsym)))
684 (if (functionp fun)
685 `(funcall #',fun ,arg)
686 `(,@fun ,arg)))))
687 (if (null vs)
688 call
689 ;; Let's not replace `vars' in `fun' since it's
690 ;; too difficult to do it right, instead just
691 ;; let-bind `vars' around `fun'.
692 `(let* ,env ,call)))))
693
694(defun pcase--eval (exp vars)
695 "Build an expression that will evaluate EXP."
696 (let* ((found (assq exp vars)))
697 (if found (cdr found)
698 (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
699 (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
700 vs)))
701 (if env (macroexp-let* env exp) exp)))))
702
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200703;; It's very tempting to use `pcase' below, tho obviously, it'd create
704;; bootstrapping problems.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500705(defun pcase--u1 (matches code vars rest)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200706 "Return code that runs CODE (with VARS) if MATCHES match.
ca3afb79 Juanma Barranquero2011-02-28 05:24:40 +0100707Otherwise, it defers to REST which is a list of branches of the form
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200708\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
709 ;; Depending on the order in which we choose to check each of the MATCHES,
710 ;; the resulting tree may be smaller or bigger. So in general, we'd want
711 ;; to be careful to chose the "optimal" order. But predicate
712 ;; patterns make this harder because they create dependencies
713 ;; between matches. So we don't bother trying to reorder anything.
714 (cond
715 ((null matches) (funcall code vars))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500716 ((eq :pcase--fail (car matches)) (pcase--u rest))
717 ((eq :pcase--succeed (car matches))
718 (pcase--u1 (cdr matches) code vars rest))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200719 ((eq 'and (caar matches))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500720 (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200721 ((eq 'or (caar matches))
722 (let* ((alts (cdar matches))
723 (var (if (eq (caar alts) 'match) (cadr (car alts))))
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400724 (simples '()) (others '()) (memq-ok t))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200725 (when var
726 (dolist (alt alts)
727 (if (and (eq (car alt) 'match) (eq var (cadr alt))
728 (let ((upat (cddr alt)))
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400729 (eq (car-safe upat) 'quote)))
730 (let ((val (cadr (cddr alt))))
731 (unless (or (integerp val) (symbolp val))
732 (setq memq-ok nil))
733 (push (cadr (cddr alt)) simples))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200734 (push alt others))))
735 (cond
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500736 ((null alts) (error "Please avoid it") (pcase--u rest))
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400737 ;; Yes, we can use `memq' (or `member')!
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200738 ((> (length simples) 1)
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400739 (pcase--u1 (cons `(match ,var
740 . (pred (pcase--flip
741 ,(if memq-ok #'memq #'member)
742 ',simples)))
743 (cdr matches))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500744 code vars
745 (if (null others) rest
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500746 (cons (cons
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500747 (pcase--and (if (cdr others)
748 (cons 'or (nreverse others))
749 (car others))
750 (cdr matches))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500751 (cons code vars))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500752 rest))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200753 (t
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500754 (pcase--u1 (cons (pop alts) (cdr matches)) code vars
755 (if (null alts) (progn (error "Please avoid it") rest)
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500756 (cons (cons
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500757 (pcase--and (if (cdr alts)
758 (cons 'or alts) (car alts))
759 (cdr matches))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500760 (cons code vars))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500761 rest)))))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200762 ((eq 'match (caar matches))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500763 (let* ((popmatches (pop matches))
d032d5e7 Stefan Monnier2011-03-01 00:03:24 -0500764 (_op (car popmatches)) (cdrpopmatches (cdr popmatches))
9a05edc4
SM
Stefan Monnier2011-02-18 08:55:51 -0500765 (sym (car cdrpopmatches))
766 (upat (cdr cdrpopmatches)))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200767 (cond
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500768 ((memq upat '(t _)) (pcase--u1 matches code vars rest))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400769 ((eq upat 'pcase--dontcare) :pcase--dontcare)
dcc029e0 Stefan Monnier2010-10-28 21:05:38 -0400770 ((memq (car-safe upat) '(guard pred))
7f457c06 Stefan Monnier2012-09-28 08:18:38 -0400771 (if (eq (car upat) 'pred) (pcase--mark-used sym))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500772 (let* ((splitrest
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400773 (pcase--split-rest
0b64b838 Stefan Monnier2013-07-08 17:54:54 -0400774 sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
9a05edc4
SM
Stefan Monnier2011-02-18 08:55:51 -0500775 (then-rest (car splitrest))
776 (else-rest (cdr splitrest)))
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400777 (pcase--if (if (eq (car upat) 'pred)
778 (pcase--funcall (cadr upat) sym vars)
779 (pcase--eval (cadr upat) vars))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500780 (pcase--u1 matches code vars then-rest)
781 (pcase--u else-rest))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200782 ((symbolp upat)
7f457c06 Stefan Monnier2012-09-28 08:18:38 -0400783 (pcase--mark-used sym)
f9d554dd
SM
Stefan Monnier2011-02-17 23:58:21 -0500784 (if (not (assq upat vars))
785 (pcase--u1 matches code (cons (cons upat sym) vars) rest)
786 ;; Non-linear pattern. Turn it into an `eq' test.
787 (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
788 matches)
789 code vars rest)))
ca105506
SM
Stefan Monnier2011-03-16 16:08:39 -0400790 ((eq (car-safe upat) 'let)
791 ;; A upat of the form (let VAR EXP).
792 ;; (pcase--u1 matches code
793 ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
2ee3d7f0 Stefan Monnier2012-06-22 09:42:38 -0400794 (macroexp-let2
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400795 macroexp-copyable-p sym
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400796 (pcase--eval (nth 2 upat) vars)
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400797 (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400798 code vars rest)))
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400799 ((eq (car-safe upat) 'app)
800 ;; A upat of the form (app FUN UPAT)
801 (pcase--mark-used sym)
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400802 (let* ((fun (nth 1 upat))
803 (nsym (make-symbol "x"))
804 (body
805 ;; We don't change `matches' to reuse the newly computed value,
806 ;; because we assume there shouldn't be such redundancy in there.
807 (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
808 code vars
809 (pcase--app-subst-rest rest sym fun nsym))))
810 (if (not (get nsym 'pcase-used))
811 body
812 (macroexp-let*
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400813 `((,nsym ,(pcase--funcall fun sym vars)))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400814 body))))
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400815 ((eq (car-safe upat) 'quote)
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400816 (pcase--mark-used sym)
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400817 (let* ((val (cadr upat))
818 (splitrest (pcase--split-rest
819 sym (lambda (pat) (pcase--split-equal val pat)) rest))
820 (then-rest (car splitrest))
821 (else-rest (cdr splitrest)))
822 (pcase--if (cond
823 ((null val) `(null ,sym))
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400824 ((or (integerp val) (symbolp val))
825 (if (pcase--self-quoting-p val)
826 `(eq ,sym ,val)
827 `(eq ,sym ',val)))
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400828 (t `(equal ,sym ',val)))
829 (pcase--u1 matches code vars then-rest)
830 (pcase--u else-rest))))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200831 ((eq (car-safe upat) 'not)
832 ;; FIXME: The implementation below is naive and results in
833 ;; inefficient code.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500834 ;; To make it work right, we would need to turn pcase--u1's
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200835 ;; `code' and `vars' into a single argument of the same form as
836 ;; `rest'. We would also need to split this new `then-rest' argument
837 ;; for every test (currently we don't bother to do it since
838 ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
839 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
840 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500841 (pcase--u1 `((match ,sym . ,(cadr upat)))
94d11cb5
IK
Igor Kuzmin2011-02-10 13:53:49 -0500842 ;; FIXME: This codegen is not careful to share its
843 ;; code if used several times: code blow up is likely.
d032d5e7 Stefan Monnier2011-03-01 00:03:24 -0500844 (lambda (_vars)
94d11cb5
IK
Igor Kuzmin2011-02-10 13:53:49 -0500845 ;; `vars' will likely contain bindings which are
846 ;; not always available in other paths to
847 ;; `rest', so there' no point trying to pass
848 ;; them down.
849 (pcase--u rest))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500850 vars
851 (list `((and . ,matches) ,code . ,vars))))
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400852 (t (error "Unknown internal pattern `%S'" upat)))))
853 (t (error "Incorrect MATCH %S" (car matches)))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200854
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +0200855(def-edebug-spec
856 pcase-QPAT
857 (&or ("," pcase-UPAT)
858 (pcase-QPAT . pcase-QPAT)
859 (vector &rest pcase-QPAT)
860 sexp))
861
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400862(pcase-defmacro \` (qpat)
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400863 "Backquote-style pcase patterns.
864QPAT can take the following forms:
865 (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
866 [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
867 its 0..(n-1)th elements, respectively.
868 ,UPAT matches if the UPattern UPAT matches.
869 STRING matches if the object is `equal' to STRING.
870 ATOM matches if the object is `eq' to ATOM."
2e47de36 Johan Bockgård2015-04-12 16:26:52 +0200871 (declare (debug (pcase-QPAT)))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200872 (cond
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400873 ((eq (car-safe qpat) '\,) (cadr qpat))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200874 ((vectorp qpat)
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400875 `(and (pred vectorp)
876 (app length ,(length qpat))
877 ,@(let ((upats nil))
878 (dotimes (i (length qpat))
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400879 (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400880 upats))
881 (nreverse upats))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200882 ((consp qpat)
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400883 `(and (pred consp)
884 (app car ,(list '\` (car qpat)))
885 (app cdr ,(list '\` (cdr qpat)))))
886 ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)))
97eedd1b Glenn Morris2010-08-10 19:14:53 -0700887
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200888
889(provide 'pcase)
890;;; pcase.el ends here