Minor improvements in Bulgarian input methods
[emacs.git] / lisp / emacs-lisp / pcase.el
1 ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
2
3 ;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
4
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6 ;; Keywords:
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
28 ;; Todo:
29
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.
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
38 ;;   extension provide its own `pcase--split-<foo>' thingy.
39 ;; - along these lines, provide patterns to match CL structs.
40 ;; - provide something like (setq VAR) so a var can be set rather than
41 ;;   let-bound.
42 ;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
43 ;;   this :-()
44 ;; - try and be more clever to reduce the size of the decision tree, and
45 ;;   to reduce the number of leaves that need to be turned into function:
46 ;;   - first, do the tests shared by all remaining branches (it will have
47 ;;     to be performed anyway, so better do it first so it's shared).
48 ;;   - then choose the test that discriminates more (?).
49 ;; - provide Agda's `with' (along with its `...' companion).
50 ;; - implement (not UPAT).  This might require a significant redesign.
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
54 ;;; Code:
55
56 (require 'macroexp)
57
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.
63 ;; FIXME: Now that macroexpansion is also performed when loading an interpreted
64 ;; file, this is not a real problem any more.
65 (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
66 ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
67 ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
68
69 (defconst pcase--dontcare-upats '(t _ pcase--dontcare))
70
71 (defvar pcase--dontwarn-upats '(pcase--dontcare))
72
73 (def-edebug-spec
74   pcase-UPAT
75   (&or symbolp
76        ("or" &rest pcase-UPAT)
77        ("and" &rest pcase-UPAT)
78        ("guard" form)
79        ("let" pcase-UPAT form)
80        ("pred" pcase-FUN)
81        ("app" pcase-FUN pcase-UPAT)
82        pcase-MACRO
83        sexp))
84
85 (def-edebug-spec
86   pcase-FUN
87   (&or lambda-expr
88        ;; Punt on macros/special forms.
89        (functionp &rest form)
90        sexp))
91
92 (def-edebug-spec pcase-MACRO pcase--edebug-match-macro)
93
94 (defun pcase--edebug-match-macro (cursor)
95   (let (specs)
96     (mapatoms
97      (lambda (s)
98        (let ((m (get s 'pcase-macroexpander)))
99          (when (and m (get-edebug-spec m))
100            (push (cons (symbol-name s) (get-edebug-spec m))
101                  specs)))))
102     (edebug-match cursor (cons '&or specs))))
103
104 ;;;###autoload
105 (defmacro pcase (exp &rest cases)
106   "Perform ML-style pattern matching on EXP.
107 CASES is a list of elements of the form (UPATTERN CODE...).
108
109 UPatterns can take the following forms:
110   _             matches anything.
111   SELFQUOTING   matches itself.  This includes keywords, numbers, and strings.
112   SYMBOL        matches anything and binds it to SYMBOL.
113   (or UPAT...)  matches if any of the patterns matches.
114   (and UPAT...) matches if all the patterns match.
115   'VAL          matches if the object is `equal' to VAL
116   (pred FUN)    matches if FUN applied to the object returns non-nil.
117   (guard BOOLEXP)       matches if BOOLEXP evaluates to non-nil.
118   (let UPAT EXP)        matches if EXP matches UPAT.
119   (app FUN UPAT)        matches if FUN applied to the object matches UPAT.
120 If a SYMBOL is used twice in the same pattern (i.e. the pattern is
121 \"non-linear\"), then the second occurrence is turned into an `eq'uality test.
122
123 FUN can take the form
124   SYMBOL or (lambda ARGS BODY)  in which case it's called with one argument.
125   (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
126                         which is the value being matched.
127 So a FUN of the form SYMBOL is equivalent to one of the form (FUN).
128 FUN can refer to variables bound earlier in the pattern.
129 FUN is assumed to be pure, i.e. it can be dropped if its result is not used,
130 and two identical calls can be merged into one.
131 E.g. you can match pairs where the cdr is larger than the car with a pattern
132 like `(,a . ,(pred (< a))) or, with more checks:
133 `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))
134
135 Additional patterns can be defined via `pcase-defmacro'.
136 Currently, the following patterns are provided this way:"
137   (declare (indent 1) (debug (form &rest (pcase-UPAT body))))
138   ;; We want to use a weak hash table as a cache, but the key will unavoidably
139   ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
140   ;; we're called so it'll be immediately GC'd.  So we use (car cases) as key
141   ;; which does come straight from the source code and should hence not be GC'd
142   ;; so easily.
143   (let ((data (gethash (car cases) pcase--memoize)))
144     ;; data = (EXP CASES . EXPANSION)
145     (if (and (equal exp (car data)) (equal cases (cadr data)))
146         ;; We have the right expansion.
147         (cddr data)
148       ;; (when (gethash (car cases) pcase--memoize-1)
149       ;;   (message "pcase-memoize failed because of weak key!!"))
150       ;; (when (gethash (car cases) pcase--memoize-2)
151       ;;   (message "pcase-memoize failed because of eq test on %S"
152       ;;            (car cases)))
153       (when data
154         (message "pcase-memoize: equal first branch, yet different"))
155       (let ((expansion (pcase--expand exp cases)))
156         (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
157         ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
158         ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
159         expansion))))
160
161 ;; FIXME: Obviously, this will collide with nadvice's use of
162 ;; function-documentation if we happen to advise `pcase'.
163 (put 'pcase 'function-documentation '(pcase--make-docstring))
164 (defun pcase--make-docstring ()
165   (let* ((main (documentation (symbol-function 'pcase) 'raw))
166          (ud (help-split-fundoc main 'pcase)))
167     (with-temp-buffer
168       (insert (or (cdr ud) main))
169       (mapatoms
170        (lambda (symbol)
171          (let ((me (get symbol 'pcase-macroexpander)))
172            (when me
173              (insert "\n\n-- ")
174              (let* ((doc (documentation me 'raw)))
175                (setq doc (help-fns--signature symbol doc me
176                                               (indirect-function me)))
177                (insert "\n" (or doc "Not documented.")))))))
178       (let ((combined-doc (buffer-string)))
179         (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
180
181 ;;;###autoload
182 (defmacro pcase-exhaustive (exp &rest cases)
183   "The exhaustive version of `pcase' (which see)."
184   (declare (indent 1) (debug pcase))
185   (let* ((x (make-symbol "x"))
186          (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
187     (pcase--expand
188      ;; FIXME: Could we add the FILE:LINE data in the error message?
189      exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
190
191 ;;;###autoload
192 (defmacro pcase-lambda (lambda-list &rest body)
193   "Like `lambda' but allow each argument to be a UPattern.
194 I.e. accepts the usual &optional and &rest keywords, but every
195 formal argument can be any pattern accepted by `pcase' (a mere
196 variable name being but a special case of it)."
197   (declare (doc-string 2) (indent defun)
198            (debug ((&rest pcase-UPAT) body)))
199   (let* ((bindings ())
200          (parsed-body (macroexp-parse-body body))
201          (args (mapcar (lambda (pat)
202                          (if (symbolp pat)
203                              ;; Simple vars and &rest/&optional are just passed
204                              ;; through unchanged.
205                              pat
206                            (let ((arg (make-symbol
207                                        (format "arg%s" (length bindings)))))
208                              (push `(,pat ,arg) bindings)
209                              arg)))
210                        lambda-list)))
211     `(lambda ,args ,@(car parsed-body)
212        (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
213
214 (defun pcase--let* (bindings body)
215   (cond
216    ((null bindings) (macroexp-progn body))
217    ((pcase--trivial-upat-p (caar bindings))
218     (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
219    (t
220     (let ((binding (pop bindings)))
221       (pcase--expand
222        (cadr binding)
223        `((,(car binding) ,(pcase--let* bindings body))
224          ;; We can either signal an error here, or just use `pcase--dontcare'
225          ;; which generates more efficient code.  In practice, if we use
226          ;; `pcase--dontcare' we will still often get an error and the few
227          ;; cases where we don't do not matter that much, so
228          ;; it's a better choice.
229          (pcase--dontcare nil)))))))
230
231 ;;;###autoload
232 (defmacro pcase-let* (bindings &rest body)
233   "Like `let*' but where you can use `pcase' patterns for bindings.
234 BODY should be an expression, and BINDINGS should be a list of bindings
235 of the form (UPAT EXP)."
236   (declare (indent 1)
237            (debug ((&rest (pcase-UPAT &optional form)) body)))
238   (let ((cached (gethash bindings pcase--memoize)))
239     ;; cached = (BODY . EXPANSION)
240     (if (equal (car cached) body)
241         (cdr cached)
242       (let ((expansion (pcase--let* bindings body)))
243         (puthash bindings (cons body expansion) pcase--memoize)
244         expansion))))
245
246 ;;;###autoload
247 (defmacro pcase-let (bindings &rest body)
248   "Like `let' but where you can use `pcase' patterns for bindings.
249 BODY should be a list of expressions, and BINDINGS should be a list of bindings
250 of the form (UPAT EXP)."
251   (declare (indent 1) (debug pcase-let*))
252   (if (null (cdr bindings))
253       `(pcase-let* ,bindings ,@body)
254     (let ((matches '()))
255       (dolist (binding (prog1 bindings (setq bindings nil)))
256         (cond
257          ((memq (car binding) pcase--dontcare-upats)
258           (push (cons (make-symbol "_") (cdr binding)) bindings))
259          ((pcase--trivial-upat-p (car binding)) (push binding bindings))
260          (t
261           (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
262             (push (cons tmpvar (cdr binding)) bindings)
263             (push (list (car binding) tmpvar) matches)))))
264       `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
265
266 ;;;###autoload
267 (defmacro pcase-dolist (spec &rest body)
268   (declare (indent 1) (debug ((pcase-UPAT form) body)))
269   (if (pcase--trivial-upat-p (car spec))
270       `(dolist ,spec ,@body)
271     (let ((tmpvar (make-symbol "x")))
272       `(dolist (,tmpvar ,@(cdr spec))
273          (pcase-let* ((,(car spec) ,tmpvar))
274            ,@body)))))
275
276
277 (defun pcase--trivial-upat-p (upat)
278   (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
279
280 (defun pcase--expand (exp cases)
281   ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
282   ;;          (emacs-pid) exp (sxhash cases))
283   (macroexp-let2 macroexp-copyable-p val exp
284     (let* ((defs ())
285            (seen '())
286            (codegen
287             (lambda (code vars)
288               (let ((prev (assq code seen)))
289                 (if (not prev)
290                     (let ((res (pcase-codegen code vars)))
291                       (push (list code vars res) seen)
292                       res)
293                   ;; Since we use a tree-based pattern matching
294                   ;; technique, the leaves (the places that contain the
295                   ;; code to run once a pattern is matched) can get
296                   ;; copied a very large number of times, so to avoid
297                   ;; code explosion, we need to keep track of how many
298                   ;; times we've used each leaf and move it
299                   ;; to a separate function if that number is too high.
300                   ;;
301                   ;; We've already used this branch.  So it is shared.
302                   (let* ((code (car prev))         (cdrprev (cdr prev))
303                          (prevvars (car cdrprev))  (cddrprev (cdr cdrprev))
304                          (res (car cddrprev)))
305                     (unless (symbolp res)
306                       ;; This is the first repeat, so we have to move
307                       ;; the branch to a separate function.
308                       (let ((bsym
309                              (make-symbol (format "pcase-%d" (length defs)))))
310                         (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code))
311                               defs)
312                         (setcar res 'funcall)
313                         (setcdr res (cons bsym (mapcar #'cdr prevvars)))
314                         (setcar (cddr prev) bsym)
315                         (setq res bsym)))
316                     (setq vars (copy-sequence vars))
317                     (let ((args (mapcar (lambda (pa)
318                                           (let ((v (assq (car pa) vars)))
319                                             (setq vars (delq v vars))
320                                             (cdr v)))
321                                         prevvars)))
322                       ;; If some of `vars' were not found in `prevvars', that's
323                       ;; OK it just means those vars aren't present in all
324                       ;; branches, so they can be used within the pattern
325                       ;; (e.g. by a `guard/let/pred') but not in the branch.
326                       ;; FIXME: But if some of `prevvars' are not in `vars' we
327                       ;; should remove them from `prevvars'!
328                       `(funcall ,res ,@args)))))))
329            (used-cases ())
330            (main
331             (pcase--u
332              (mapcar (lambda (case)
333                        `(,(pcase--match val (pcase--macroexpand (car case)))
334                          ,(lambda (vars)
335                             (unless (memq case used-cases)
336                               ;; Keep track of the cases that are used.
337                               (push case used-cases))
338                             (funcall
339                              (if (pcase--small-branch-p (cdr case))
340                                  ;; Don't bother sharing multiple
341                                  ;; occurrences of this leaf since it's small.
342                                  #'pcase-codegen codegen)
343                              (cdr case)
344                              vars))))
345                      cases))))
346       (dolist (case cases)
347         (unless (or (memq case used-cases)
348                     (memq (car case) pcase--dontwarn-upats))
349           (message "Redundant pcase pattern: %S" (car case))))
350       (macroexp-let* defs main))))
351
352 (defun pcase--macroexpand (pat)
353   "Expands all macro-patterns in PAT."
354   (let ((head (car-safe pat)))
355     (cond
356      ((null head)
357       (if (pcase--self-quoting-p pat) `',pat pat))
358      ((memq head '(pred guard quote)) pat)
359      ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
360      ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
361      ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
362      (t
363       (let* ((expander (get head 'pcase-macroexpander))
364              (npat (if expander (apply expander (cdr pat)))))
365         (if (null npat)
366             (error (if expander
367                        "Unexpandable %s pattern: %S"
368                      "Unknown %s pattern: %S")
369                    head pat)
370           (pcase--macroexpand npat)))))))
371
372 ;;;###autoload
373 (defmacro pcase-defmacro (name args &rest body)
374   "Define a pcase UPattern macro."
375   (declare (indent 2) (debug defun) (doc-string 3))
376   ;; Add the function via `fsym', so that an autoload cookie placed
377   ;; on a pcase-defmacro will cause the macro to be loaded on demand.
378   (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
379         (decl (assq 'declare body)))
380     (when decl (setq body (remove decl body)))
381     `(progn
382        (defun ,fsym ,args ,@body)
383        (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
384        (put ',name 'pcase-macroexpander #',fsym))))
385
386 (defun pcase--match (val upat)
387   "Build a MATCH structure, hoisting all `or's and `and's outside."
388   (cond
389    ;; Hoist or/and patterns into or/and matches.
390    ((memq (car-safe upat) '(or and))
391     `(,(car upat)
392       ,@(mapcar (lambda (upat)
393                   (pcase--match val upat))
394                 (cdr upat))))
395    (t
396     `(match ,val . ,upat))))
397
398 (defun pcase-codegen (code vars)
399   ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
400   ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
401   ;; codegen from later metamorphosing this let into a funcall.
402   `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
403      ,@code))
404
405 (defun pcase--small-branch-p (code)
406   (and (= 1 (length code))
407        (or (not (consp (car code)))
408            (let ((small t))
409              (dolist (e (car code))
410                (if (consp e) (setq small nil)))
411              small))))
412
413 ;; Try to use `cond' rather than a sequence of `if's, so as to reduce
414 ;; the depth of the generated tree.
415 (defun pcase--if (test then else)
416   (cond
417    ((eq else :pcase--dontcare) then)
418    ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
419    (t (macroexp-if test then else))))
420
421 ;; Note about MATCH:
422 ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
423 ;; check, we want to turn all the similar patterns into ones of the form
424 ;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
425 ;; Earlier code hence used branches of the form (MATCHES . CODE) where
426 ;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
427 ;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
428 ;; no easy way to eliminate the `consp' check in such a representation.
429 ;; So we replaced the MATCHES by the MATCH below which can be made up
430 ;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
431 ;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
432 ;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
433 ;; The downside is that we now have `or' and `and' both in MATCH and
434 ;; in PAT, so there are different equivalent representations and we
435 ;; need to handle them all.  We do not try to systematically
436 ;; canonicalize them to one form over another, but we do occasionally
437 ;; turn one into the other.
438
439 (defun pcase--u (branches)
440   "Expand matcher for rules BRANCHES.
441 Each BRANCH has the form (MATCH CODE . VARS) where
442 CODE is the code generator for that branch.
443 VARS is the set of vars already bound by earlier matches.
444 MATCH is the pattern that needs to be matched, of the form:
445   (match VAR . UPAT)
446   (and MATCH ...)
447   (or MATCH ...)"
448   (when (setq branches (delq nil branches))
449     (let* ((carbranch (car branches))
450            (match (car carbranch)) (cdarbranch (cdr carbranch))
451            (code (car cdarbranch))
452            (vars (cdr cdarbranch)))
453       (pcase--u1 (list match) code vars (cdr branches)))))
454
455 (defun pcase--and (match matches)
456   (if matches `(and ,match ,@matches) match))
457
458 (defconst pcase-mutually-exclusive-predicates
459   '((symbolp . integerp)
460     (symbolp . numberp)
461     (symbolp . consp)
462     (symbolp . arrayp)
463     (symbolp . vectorp)
464     (symbolp . stringp)
465     (symbolp . byte-code-function-p)
466     (integerp . consp)
467     (integerp . arrayp)
468     (integerp . vectorp)
469     (integerp . stringp)
470     (integerp . byte-code-function-p)
471     (numberp . consp)
472     (numberp . arrayp)
473     (numberp . vectorp)
474     (numberp . stringp)
475     (numberp . byte-code-function-p)
476     (consp . arrayp)
477     (consp . vectorp)
478     (consp . stringp)
479     (consp . byte-code-function-p)
480     (arrayp . byte-code-function-p)
481     (vectorp . byte-code-function-p)
482     (stringp . vectorp)
483     (stringp . byte-code-function-p)))
484
485 (defun pcase--mutually-exclusive-p (pred1 pred2)
486   (or (member (cons pred1 pred2)
487               pcase-mutually-exclusive-predicates)
488       (member (cons pred2 pred1)
489               pcase-mutually-exclusive-predicates)))
490
491 (defun pcase--split-match (sym splitter match)
492   (cond
493     ((eq (car-safe match) 'match)
494      (if (not (eq sym (cadr match)))
495          (cons match match)
496        (let ((res (funcall splitter (cddr match))))
497          (cons (or (car res) match) (or (cdr res) match)))))
498     ((memq (car-safe match) '(or and))
499      (let ((then-alts '())
500            (else-alts '())
501            (neutral-elem (if (eq 'or (car match))
502                              :pcase--fail :pcase--succeed))
503            (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
504        (dolist (alt (cdr match))
505          (let ((split (pcase--split-match sym splitter alt)))
506            (unless (eq (car split) neutral-elem)
507              (push (car split) then-alts))
508            (unless (eq (cdr split) neutral-elem)
509              (push (cdr split) else-alts))))
510        (cons (cond ((memq zero-elem then-alts) zero-elem)
511                    ((null then-alts) neutral-elem)
512                    ((null (cdr then-alts)) (car then-alts))
513                    (t (cons (car match) (nreverse then-alts))))
514              (cond ((memq zero-elem else-alts) zero-elem)
515                    ((null else-alts) neutral-elem)
516                    ((null (cdr else-alts)) (car else-alts))
517                    (t (cons (car match) (nreverse else-alts)))))))
518     ((memq match '(:pcase--succeed :pcase--fail)) (cons match match))
519     (t (error "Uknown MATCH %s" match))))
520
521 (defun pcase--split-rest (sym splitter rest)
522   (let ((then-rest '())
523         (else-rest '()))
524     (dolist (branch rest)
525       (let* ((match (car branch))
526              (code&vars (cdr branch))
527              (split
528               (pcase--split-match sym splitter match)))
529         (unless (eq (car split) :pcase--fail)
530           (push (cons (car split) code&vars) then-rest))
531         (unless (eq (cdr split) :pcase--fail)
532           (push (cons (cdr split) code&vars) else-rest))))
533     (cons (nreverse then-rest) (nreverse else-rest))))
534
535 (defun pcase--split-equal (elem pat)
536   (cond
537    ;; The same match will give the same result.
538    ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
539     '(:pcase--succeed . :pcase--fail))
540    ;; A different match will fail if this one succeeds.
541    ((and (eq (car-safe pat) 'quote)
542          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
543          ;;     (consp (cadr pat)))
544          )
545     '(:pcase--fail . nil))
546    ((and (eq (car-safe pat) 'pred)
547          (symbolp (cadr pat))
548          (get (cadr pat) 'side-effect-free))
549     (ignore-errors
550       (if (funcall (cadr pat) elem)
551           '(:pcase--succeed . nil)
552         '(:pcase--fail . nil))))))
553
554 (defun pcase--split-member (elems pat)
555   ;; FIXME: The new pred-based member code doesn't do these optimizations!
556   ;; Based on pcase--split-equal.
557   (cond
558    ;; The same match (or a match of membership in a superset) will
559    ;; give the same result, but we don't know how to check it.
560    ;; (???
561    ;;  '(:pcase--succeed . nil))
562    ;; A match for one of the elements may succeed or fail.
563    ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
564     nil)
565    ;; A different match will fail if this one succeeds.
566    ((and (eq (car-safe pat) 'quote)
567          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
568          ;;     (consp (cadr pat)))
569          )
570     '(:pcase--fail . nil))
571    ((and (eq (car-safe pat) 'pred)
572          (symbolp (cadr pat))
573          (get (cadr pat) 'side-effect-free)
574          (ignore-errors
575            (let ((p (cadr pat)) (all t))
576              (dolist (elem elems)
577                (unless (funcall p elem) (setq all nil)))
578              all)))
579     '(:pcase--succeed . nil))))
580
581 (defun pcase--split-pred (vars upat pat)
582   (let (test)
583     (cond
584      ((and (equal upat pat)
585            ;; For predicates like (pred (> a)), two such predicates may
586            ;; actually refer to different variables `a'.
587            (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
588                ;; FIXME: `vars' gives us the environment in which `upat' will
589                ;; run, but we don't have the environment in which `pat' will
590                ;; run, so we can't do a reliable verification.  But let's try
591                ;; and catch at least the easy cases such as (bug#14773).
592                (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
593       '(:pcase--succeed . :pcase--fail))
594      ((and (eq 'pred (car upat))
595            (let ((otherpred
596                   (cond ((eq 'pred (car-safe pat)) (cadr pat))
597                         ((not (eq 'quote (car-safe pat))) nil)
598                         ((consp (cadr pat)) #'consp)
599                         ((stringp (cadr pat)) #'stringp)
600                         ((vectorp (cadr pat)) #'vectorp)
601                         ((byte-code-function-p (cadr pat))
602                          #'byte-code-function-p))))
603              (pcase--mutually-exclusive-p (cadr upat) otherpred)))
604       '(:pcase--fail . nil))
605      ((and (eq 'pred (car upat))
606            (eq 'quote (car-safe pat))
607            (symbolp (cadr upat))
608            (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
609            (get (cadr upat) 'side-effect-free)
610            (ignore-errors
611              (setq test (list (funcall (cadr upat) (cadr pat))))))
612       (if (car test)
613           '(nil . :pcase--fail)
614         '(:pcase--fail . nil))))))
615
616 (defun pcase--fgrep (vars sexp)
617   "Check which of the symbols VARS appear in SEXP."
618   (let ((res '()))
619     (while (consp sexp)
620       (dolist (var (pcase--fgrep vars (pop sexp)))
621         (unless (memq var res) (push var res))))
622     (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
623     res))
624
625 (defun pcase--self-quoting-p (upat)
626   (or (keywordp upat) (numberp upat) (stringp upat)))
627
628 (defun pcase--app-subst-match (match sym fun nsym)
629   (cond
630    ((eq (car-safe match) 'match)
631     (if (and (eq sym (cadr match))
632              (eq 'app (car-safe (cddr match)))
633              (equal fun (nth 1 (cddr match))))
634         (pcase--match nsym (nth 2 (cddr match)))
635       match))
636    ((memq (car-safe match) '(or and))
637     `(,(car match)
638       ,@(mapcar (lambda (match)
639                   (pcase--app-subst-match match sym fun nsym))
640                 (cdr match))))
641    ((memq match '(:pcase--succeed :pcase--fail)) match)
642    (t (error "Uknown MATCH %s" match))))
643
644 (defun pcase--app-subst-rest (rest sym fun nsym)
645   (mapcar (lambda (branch)
646             `(,(pcase--app-subst-match (car branch) sym fun nsym)
647               ,@(cdr branch)))
648           rest))
649
650 (defsubst pcase--mark-used (sym)
651   ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
652   (if (symbolp sym) (put sym 'pcase-used t)))
653
654 (defmacro pcase--flip (fun arg1 arg2)
655   "Helper function, used internally to avoid (funcall (lambda ...) ...)."
656   (declare (debug (sexp body)))
657   `(,fun ,arg2 ,arg1))
658
659 (defun pcase--funcall (fun arg vars)
660   "Build a function call to FUN with arg ARG."
661   (if (symbolp fun)
662       `(,fun ,arg)
663     (let* (;; `vs' is an upper bound on the vars we need.
664            (vs (pcase--fgrep (mapcar #'car vars) fun))
665            (env (mapcar (lambda (var)
666                           (list var (cdr (assq var vars))))
667                         vs))
668            (call (progn
669                    (when (memq arg vs)
670                      ;; `arg' is shadowed by `env'.
671                      (let ((newsym (make-symbol "x")))
672                        (push (list newsym arg) env)
673                        (setq arg newsym)))
674                    (if (functionp fun)
675                        `(funcall #',fun ,arg)
676                      `(,@fun ,arg)))))
677       (if (null vs)
678           call
679         ;; Let's not replace `vars' in `fun' since it's
680         ;; too difficult to do it right, instead just
681         ;; let-bind `vars' around `fun'.
682         `(let* ,env ,call)))))
683
684 (defun pcase--eval (exp vars)
685   "Build an expression that will evaluate EXP."
686   (let* ((found (assq exp vars)))
687     (if found (cdr found)
688       (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
689              (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
690                           vs)))
691         (if env (macroexp-let* env exp) exp)))))
692
693 ;; It's very tempting to use `pcase' below, tho obviously, it'd create
694 ;; bootstrapping problems.
695 (defun pcase--u1 (matches code vars rest)
696   "Return code that runs CODE (with VARS) if MATCHES match.
697 Otherwise, it defers to REST which is a list of branches of the form
698 \(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
699   ;; Depending on the order in which we choose to check each of the MATCHES,
700   ;; the resulting tree may be smaller or bigger.  So in general, we'd want
701   ;; to be careful to chose the "optimal" order.  But predicate
702   ;; patterns make this harder because they create dependencies
703   ;; between matches.  So we don't bother trying to reorder anything.
704   (cond
705    ((null matches) (funcall code vars))
706    ((eq :pcase--fail (car matches)) (pcase--u rest))
707    ((eq :pcase--succeed (car matches))
708     (pcase--u1 (cdr matches) code vars rest))
709    ((eq 'and (caar matches))
710     (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
711    ((eq 'or (caar matches))
712     (let* ((alts (cdar matches))
713            (var (if (eq (caar alts) 'match) (cadr (car alts))))
714            (simples '()) (others '()) (memq-ok t))
715       (when var
716         (dolist (alt alts)
717           (if (and (eq (car alt) 'match) (eq var (cadr alt))
718                    (let ((upat (cddr alt)))
719                      (eq (car-safe upat) 'quote)))
720               (let ((val (cadr (cddr alt))))
721                 (unless (or (integerp val) (symbolp val))
722                   (setq memq-ok nil))
723                 (push (cadr (cddr alt)) simples))
724             (push alt others))))
725       (cond
726        ((null alts) (error "Please avoid it") (pcase--u rest))
727        ;; Yes, we can use `memq' (or `member')!
728        ((> (length simples) 1)
729         (pcase--u1 (cons `(match ,var
730                                  . (pred (pcase--flip
731                                           ,(if memq-ok #'memq #'member)
732                                           ',simples)))
733                          (cdr matches))
734                    code vars
735                    (if (null others) rest
736                      (cons (cons
737                             (pcase--and (if (cdr others)
738                                             (cons 'or (nreverse others))
739                                           (car others))
740                                         (cdr matches))
741                             (cons code vars))
742                            rest))))
743        (t
744         (pcase--u1 (cons (pop alts) (cdr matches)) code vars
745                    (if (null alts) (progn (error "Please avoid it") rest)
746                      (cons (cons
747                             (pcase--and (if (cdr alts)
748                                             (cons 'or alts) (car alts))
749                                         (cdr matches))
750                             (cons code vars))
751                            rest)))))))
752    ((eq 'match (caar matches))
753     (let* ((popmatches (pop matches))
754            (_op (car popmatches))      (cdrpopmatches (cdr popmatches))
755            (sym (car cdrpopmatches))
756            (upat (cdr cdrpopmatches)))
757       (cond
758        ((memq upat '(t _)) (pcase--u1 matches code vars rest))
759        ((eq upat 'pcase--dontcare) :pcase--dontcare)
760        ((memq (car-safe upat) '(guard pred))
761         (if (eq (car upat) 'pred) (pcase--mark-used sym))
762         (let* ((splitrest
763                 (pcase--split-rest
764                  sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
765                (then-rest (car splitrest))
766                (else-rest (cdr splitrest)))
767           (pcase--if (if (eq (car upat) 'pred)
768                          (pcase--funcall (cadr upat) sym vars)
769                        (pcase--eval (cadr upat) vars))
770                      (pcase--u1 matches code vars then-rest)
771                      (pcase--u else-rest))))
772        ((symbolp upat)
773         (pcase--mark-used sym)
774         (if (not (assq upat vars))
775             (pcase--u1 matches code (cons (cons upat sym) vars) rest)
776           ;; Non-linear pattern.  Turn it into an `eq' test.
777           (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
778                            matches)
779                      code vars rest)))
780        ((eq (car-safe upat) 'let)
781         ;; A upat of the form (let VAR EXP).
782         ;; (pcase--u1 matches code
783         ;;            (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
784         (macroexp-let2
785             macroexp-copyable-p sym
786             (pcase--eval (nth 2 upat) vars)
787           (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
788                      code vars rest)))
789        ((eq (car-safe upat) 'app)
790         ;; A upat of the form (app FUN UPAT)
791         (pcase--mark-used sym)
792         (let* ((fun (nth 1 upat))
793                (nsym (make-symbol "x"))
794                (body
795                 ;; We don't change `matches' to reuse the newly computed value,
796                 ;; because we assume there shouldn't be such redundancy in there.
797                 (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
798                            code vars
799                            (pcase--app-subst-rest rest sym fun nsym))))
800           (if (not (get nsym 'pcase-used))
801               body
802             (macroexp-let*
803              `((,nsym ,(pcase--funcall fun sym vars)))
804              body))))
805        ((eq (car-safe upat) 'quote)
806         (pcase--mark-used sym)
807         (let* ((val (cadr upat))
808                (splitrest (pcase--split-rest
809                            sym (lambda (pat) (pcase--split-equal val pat)) rest))
810                (then-rest (car splitrest))
811                (else-rest (cdr splitrest)))
812           (pcase--if (cond
813                       ((null val) `(null ,sym))
814                       ((or (integerp val) (symbolp val))
815                        (if (pcase--self-quoting-p val)
816                            `(eq ,sym ,val)
817                          `(eq ,sym ',val)))
818                       (t `(equal ,sym ',val)))
819                      (pcase--u1 matches code vars then-rest)
820                      (pcase--u else-rest))))
821        ((eq (car-safe upat) 'not)
822         ;; FIXME: The implementation below is naive and results in
823         ;; inefficient code.
824         ;; To make it work right, we would need to turn pcase--u1's
825         ;; `code' and `vars' into a single argument of the same form as
826         ;; `rest'.  We would also need to split this new `then-rest' argument
827         ;; for every test (currently we don't bother to do it since
828         ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
829         ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
830         ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
831         (pcase--u1 `((match ,sym . ,(cadr upat)))
832                    ;; FIXME: This codegen is not careful to share its
833                    ;; code if used several times: code blow up is likely.
834                    (lambda (_vars)
835                      ;; `vars' will likely contain bindings which are
836                      ;; not always available in other paths to
837                      ;; `rest', so there' no point trying to pass
838                      ;; them down.
839                      (pcase--u rest))
840                    vars
841                    (list `((and . ,matches) ,code . ,vars))))
842        (t (error "Unknown internal pattern `%S'" upat)))))
843    (t (error "Incorrect MATCH %S" (car matches)))))
844
845 (def-edebug-spec
846   pcase-QPAT
847   (&or ("," pcase-UPAT)
848        (pcase-QPAT . pcase-QPAT)
849        (vector &rest pcase-QPAT)
850        sexp))
851
852 (pcase-defmacro \` (qpat)
853   "Backquote-style pcase patterns.
854 QPAT can take the following forms:
855   (QPAT1 . QPAT2)       matches if QPAT1 matches the car and QPAT2 the cdr.
856   [QPAT1 QPAT2..QPATn]  matches a vector of length n and QPAT1..QPATn match
857                            its 0..(n-1)th elements, respectively.
858   ,UPAT                 matches if the UPattern UPAT matches.
859   STRING                matches if the object is `equal' to STRING.
860   ATOM                  matches if the object is `eq' to ATOM."
861   (declare (debug (pcase-QPAT)))
862   (cond
863    ((eq (car-safe qpat) '\,) (cadr qpat))
864    ((vectorp qpat)
865     `(and (pred vectorp)
866           (app length ,(length qpat))
867           ,@(let ((upats nil))
868               (dotimes (i (length qpat))
869                 (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
870                       upats))
871               (nreverse upats))))
872    ((consp qpat)
873     `(and (pred consp)
874           (app car ,(list '\` (car qpat)))
875           (app cdr ,(list '\` (cdr qpat)))))
876    ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)))
877
878
879 (provide 'pcase)
880 ;;; pcase.el ends here