Mercurial > emacs
changeset 111221:e2284aa4cad3
* lisp/emacs-lisp/pcase.el (pcase): New `string' and `guard' patterns.
(pcase-if): Add one minor optimization.
(pcase-split-equal): Rename from pcase-split-eq.
(pcase-split-member): Rename from pcase-split-memq.
(pcase-u1): Add strings to the member optimization.
Add `guard' variant of predicates.
(pcase-q1): Add string patterns.
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Thu, 28 Oct 2010 21:05:38 -0400 |
| parents | fc95f9fde9d3 |
| children | cdad894f9ed0 |
| files | lisp/ChangeLog lisp/emacs-lisp/pcase.el |
| diffstat | 2 files changed, 58 insertions(+), 21 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Thu Oct 28 22:03:15 2010 +0000 +++ b/lisp/ChangeLog Thu Oct 28 21:05:38 2010 -0400 @@ -1,3 +1,13 @@ +2010-10-29 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/pcase.el (pcase): New `string' and `guard' patterns. + (pcase-if): Add one minor optimization. + (pcase-split-equal): Rename from pcase-split-eq. + (pcase-split-member): Rename from pcase-split-memq. + (pcase-u1): Add strings to the member optimization. + Add `guard' variant of predicates. + (pcase-q1): Add string patterns. + 2010-10-28 Stefan Monnier <monnier@iro.umontreal.ca> * vc/log-edit.el (log-edit-rewrite-fixes): State its safety pred.
--- a/lisp/emacs-lisp/pcase.el Thu Oct 28 22:03:15 2010 +0000 +++ b/lisp/emacs-lisp/pcase.el Thu Oct 28 21:05:38 2010 -0400 @@ -25,6 +25,16 @@ ;; ML-style pattern matching. ;; The entry points are autoloaded. +;; Todo: + +;; - provide ways to extend the set of primitives, with some kind of +;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) +;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). +;; But better would be if we could define new ways to match by having the +;; extension provide its own `pcase-split-<foo>' thingy. +;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to +;; generate a lex-style DFA to decide whether to run E1 or E2. + ;;; Code: (eval-when-compile (require 'cl)) @@ -48,10 +58,12 @@ (and UPAT...) matches if all the patterns match. `QPAT matches if the QPattern QPAT matches. (pred PRED) matches if PRED applied to the object returns non-nil. + (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. QPatterns can take the following forms: (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. ,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. QPatterns for vectors are not implemented yet. @@ -77,6 +89,8 @@ (if (null bindings) body `(pcase ,(cadr (car bindings)) (,(caar bindings) (pcase-let* ,(cdr bindings) ,body)) + ;; FIXME: In many cases `dontcare' would be preferable, so maybe we + ;; should have `let' and `elet', like we have `case' and `ecase'. (t (error "Pattern match failure in `pcase-let'"))))) ;;;###autoload @@ -167,12 +181,19 @@ (cond ((eq else :pcase-dontcare) then) ((eq (car-safe else) 'if) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else)))) + (if (equal test (nth 1 else)) + ;; Doing a test a second time: get rid of the redundancy. + ;; FIXME: ideally, this should never happen because the pcase-split-* + ;; functions should have eliminated such things, but pcase-split-member + ;; is imprecise, so in practice it does happen occasionally. + `(if ,test ,then ,@(nthcdr 3 else)) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else))))) ((eq (car-safe else) 'cond) `(cond (,test ,then) - ,@(cdr else))) + ;; Doing a test a second time: get rid of the redundancy, as above. + ,@(remove (assoc test else) (cdr else)))) (t `(if ,test ,then ,else)))) (defun pcase-upat (qpattern) @@ -276,7 +297,7 @@ ;; A QPattern but not for a cons, can only go the `else' side. ((eq (car-safe pat) '\`) (cons :pcase-fail nil)))) -(defun pcase-split-eq (elem pat) +(defun pcase-split-equal (elem pat) (cond ;; The same match will give the same result. ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) @@ -288,11 +309,11 @@ ) (cons :pcase-fail nil)))) -(defun pcase-split-memq (elems pat) - ;; Based on pcase-split-eq. +(defun pcase-split-member (elems pat) + ;; Based on pcase-split-equal. (cond - ;; The same match will give the same result, but we don't know how - ;; to check it. + ;; The same match (or a match of membership in a superset) will + ;; give the same result, but we don't know how to check it. ;; (??? ;; (cons :pcase-succeed nil)) ;; A match for one of the elements may succeed or fail. @@ -347,7 +368,8 @@ (if (and (eq (car alt) 'match) (eq var (cadr alt)) (let ((upat (cddr alt))) (and (eq (car-safe upat) '\`) - (or (integerp (cadr upat)) (symbolp (cadr upat)))))) + (or (integerp (cadr upat)) (symbolp (cadr upat)) + (stringp (cadr upat)))))) (push (cddr alt) simples) (push alt others)))) (cond @@ -380,17 +402,19 @@ ((memq upat '(t _)) (pcase-u1 matches code vars rest)) ((eq upat 'dontcare) :pcase-dontcare) ((functionp upat) (error "Feature removed, use (pred %s)" upat)) - ((eq (car-safe upat) 'pred) + ((memq (car-safe upat) '(guard pred)) (destructuring-bind (then-rest &rest else-rest) (pcase-split-rest sym (apply-partially 'pcase-split-pred upat) rest) - (pcase-if (if (symbolp (cadr upat)) + (pcase-if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) `(,(cadr upat) ,sym) (let* ((exp (cadr upat)) ;; `vs' is an upper bound on the vars we need. (vs (pcase-fgrep (mapcar #'car vars) exp)) - (call (if (functionp exp) - `(,exp ,sym) `(,@exp ,sym)))) + (call (cond + ((eq 'guard (car upat)) exp) + ((functionp exp) `(,exp ,sym)) + (t `(,@exp ,sym))))) (if (null vs) call ;; Let's not replace `vars' in `exp' since it's @@ -409,19 +433,22 @@ ((eq (car-safe upat) '\`) (pcase-q1 sym (cadr upat) matches code vars rest)) ((eq (car-safe upat) 'or) - (let ((all (> (length (cdr upat)) 1))) + (let ((all (> (length (cdr upat)) 1)) + (memq-fine t)) (when all (dolist (alt (cdr upat)) (unless (and (eq (car-safe alt) '\`) - (or (symbolp (cadr alt)) (integerp (cadr alt)))) + (or (symbolp (cadr alt)) (integerp (cadr alt)) + (setq memq-fine nil) + (stringp (cadr alt)))) (setq all nil)))) (if all ;; Use memq for (or `a `b `c `d) rather than a big tree. (let ((elems (mapcar 'cadr (cdr upat)))) (destructuring-bind (then-rest &rest else-rest) (pcase-split-rest - sym (apply-partially 'pcase-split-memq elems) rest) - (pcase-if `(memq ,sym ',elems) + sym (apply-partially 'pcase-split-member elems) rest) + (pcase-if `(,(if memq-fine #'memq #'member) ,sym ',elems) (pcase-u1 matches code vars then-rest) (pcase-u else-rest)))) (pcase-u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars @@ -483,10 +510,10 @@ ,@matches) code vars then-rest)) (pcase-u else-rest))))) - ((or (integerp qpat) (symbolp qpat)) + ((or (integerp qpat) (symbolp qpat) (stringp qpat)) (destructuring-bind (then-rest &rest else-rest) - (pcase-split-rest sym (apply-partially 'pcase-split-eq qpat) rest) - (pcase-if `(eq ,sym ',qpat) + (pcase-split-rest sym (apply-partially 'pcase-split-equal qpat) rest) + (pcase-if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) (pcase-u1 matches code vars then-rest) (pcase-u else-rest)))) (t (error "Unkown QPattern %s" qpat))))