[Emacs-diffs] /srv/bzr/emacs/trunk r102142: * lisp/emacs-lisp/pcase.el (pcase): New `string' and `guard' patterns.

[Stefan Monnier]

------------------------------------------------------------
revno: 102142
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Thu 2010-10-28 21:05:38 -0400
message:
  * 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.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/pcase.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2010-10-28 14:36:59 +0000
+++ b/lisp/ChangeLog    2010-10-29 01:05:38 +0000
@@ -1,3 +1,13 @@
+2010-10-29  Stefan Monnier  <address@hidden>
+
+       * 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  <address@hidden>
 
        * vc/log-edit.el (log-edit-rewrite-fixes): State its safety pred.

=== modified file 'lisp/emacs-lisp/pcase.el'
--- a/lisp/emacs-lisp/pcase.el  2010-09-26 22:42:53 +0000
+++ b/lisp/emacs-lisp/pcase.el  2010-10-29 01:05:38 +0000
@@ -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))))