;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
-;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:
(&or symbolp
("or" &rest pcase-UPAT)
("and" &rest pcase-UPAT)
- ("`" pcase-QPAT)
("guard" form)
("let" pcase-UPAT form)
- ("pred"
- &or lambda-expr
- ;; Punt on macros/special forms.
- (functionp &rest form)
- sexp)
+ ("pred" pcase-FUN)
+ ("app" pcase-FUN pcase-UPAT)
+ pcase-MACRO
sexp))
(def-edebug-spec
- pcase-QPAT
- (&or ("," pcase-UPAT)
- (pcase-QPAT . pcase-QPAT)
+ pcase-FUN
+ (&or lambda-expr
+ ;; Punt on macros/special forms.
+ (functionp &rest form)
sexp))
+(def-edebug-spec pcase-MACRO pcase--edebug-match-macro)
+
+(defun pcase--edebug-match-macro (cursor)
+ (let (specs)
+ (mapatoms
+ (lambda (s)
+ (let ((m (get s 'pcase-macroexpander)))
+ (when (and m (get-edebug-spec m))
+ (push (cons (symbol-name s) (get-edebug-spec m))
+ specs)))))
+ (edebug-match cursor (cons '&or specs))))
+
;;;###autoload
(defmacro pcase (exp &rest cases)
"Perform ML-style pattern matching on EXP.
(or UPAT...) matches if any of the patterns matches.
(and UPAT...) matches if all the patterns match.
'VAL matches if the object is `equal' to VAL
- `QPAT matches if the QPattern QPAT matches.
(pred FUN) matches if FUN applied to the object returns non-nil.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
(let UPAT EXP) matches if EXP matches UPAT.
If a SYMBOL is used twice in the same pattern (i.e. the pattern is
\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
-QPatterns can take the following forms:
- (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
- [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
- its 0..(n-1)th elements, respectively.
- ,UPAT matches if the UPattern UPAT matches.
- STRING matches if the object is `equal' to STRING.
- ATOM matches if the object is `eq' to ATOM.
-
FUN can take the form
SYMBOL or (lambda ARGS BODY) in which case it's called with one argument.
(F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
and two identical calls can be merged into one.
E.g. you can match pairs where the cdr is larger than the car with a pattern
like `(,a . ,(pred (< a))) or, with more checks:
-`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
+`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))
+
+Additional patterns can be defined via `pcase-defmacro'.
+Currently, the following patterns are provided this way:"
(declare (indent 1) (debug (form &rest (pcase-UPAT body))))
;; We want to use a weak hash table as a cache, but the key will unavoidably
;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
expansion))))
+;; FIXME: Obviously, this will collide with nadvice's use of
+;; function-documentation if we happen to advise `pcase'.
+(put 'pcase 'function-documentation '(pcase--make-docstring))
+(defun pcase--make-docstring ()
+ (let* ((main (documentation (symbol-function 'pcase) 'raw))
+ (ud (help-split-fundoc main 'pcase)))
+ (with-temp-buffer
+ (insert (or (cdr ud) main))
+ (mapatoms
+ (lambda (symbol)
+ (let ((me (get symbol 'pcase-macroexpander)))
+ (when me
+ (insert "\n\n-- ")
+ (let* ((doc (documentation me 'raw)))
+ (setq doc (help-fns--signature symbol doc me
+ (indirect-function me)))
+ (insert "\n" (or doc "Not documented.")))))))
+ (let ((combined-doc (buffer-string)))
+ (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
+
;;;###autoload
(defmacro pcase-exhaustive (exp &rest cases)
"The exhaustive version of `pcase' (which see)."
;; FIXME: Could we add the FILE:LINE data in the error message?
exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
+;;;###autoload
+(defmacro pcase-lambda (lambda-list &rest body)
+ "Like `lambda' but allow each argument to be a UPattern.
+I.e. accepts the usual &optional and &rest keywords, but every
+formal argument can be any pattern accepted by `pcase' (a mere
+variable name being but a special case of it)."
+ (declare (doc-string 2) (indent defun)
+ (debug ((&rest pcase-UPAT) body)))
+ (let* ((bindings ())
+ (parsed-body (macroexp-parse-body body))
+ (args (mapcar (lambda (pat)
+ (if (symbolp pat)
+ ;; Simple vars and &rest/&optional are just passed
+ ;; through unchanged.
+ pat
+ (let ((arg (make-symbol
+ (format "arg%s" (length bindings)))))
+ (push `(,pat ,arg) bindings)
+ arg)))
+ lambda-list)))
+ `(lambda ,args ,@(car parsed-body)
+ (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
+
(defun pcase--let* (bindings body)
(cond
((null bindings) (macroexp-progn body))
;;;###autoload
(defmacro pcase-defmacro (name args &rest body)
"Define a pcase UPattern macro."
- (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3))
- `(put ',name 'pcase-macroexpander
- (lambda ,args ,@body)))
+ (declare (indent 2) (debug defun) (doc-string 3))
+ ;; Add the function via `fsym', so that an autoload cookie placed
+ ;; on a pcase-defmacro will cause the macro to be loaded on demand.
+ (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
+ (decl (assq 'declare body)))
+ (when decl (setq body (remove decl body)))
+ `(progn
+ (defun ,fsym ,args ,@body)
+ (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
+ (put ',name 'pcase-macroexpander #',fsym))))
(defun pcase--match (val upat)
"Build a MATCH structure, hoisting all `or's and `and's outside."
(cond ((eq 'pred (car-safe pat)) (cadr pat))
((not (eq 'quote (car-safe pat))) nil)
((consp (cadr pat)) #'consp)
+ ((stringp (cadr pat)) #'stringp)
((vectorp (cadr pat)) #'vectorp)
((byte-code-function-p (cadr pat))
#'byte-code-function-p))))
(t (error "Unknown internal pattern `%S'" upat)))))
(t (error "Incorrect MATCH %S" (car matches)))))
+(def-edebug-spec
+ pcase-QPAT
+ (&or ("," pcase-UPAT)
+ (pcase-QPAT . pcase-QPAT)
+ (vector &rest pcase-QPAT)
+ sexp))
+
(pcase-defmacro \` (qpat)
+ "Backquote-style pcase patterns.
+QPAT can take the following forms:
+ (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
+ [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
+ its 0..(n-1)th elements, respectively.
+ ,UPAT matches if the UPattern UPAT matches.
+ STRING matches if the object is `equal' to STRING.
+ ATOM matches if the object is `eq' to ATOM."
+ (declare (debug (pcase-QPAT)))
(cond
((eq (car-safe qpat) '\,) (cadr qpat))
((vectorp qpat)