Modify: getting carried away

1 files changed, 37 insertions, 7 deletions

diff --git a/hyperquirks.lisp b/hyperquirks.lisp
index 97cf3ec..27051c5 100644
--- a/hyperquirks.lisp
+++ b/hyperquirks.lisp
@@ -115,7 +115,11 @@ returned from.
     (if (atom ls) (list ls)
         (mapcan #'flatten ls))))
 
-(defmacro >> ((&key (prefix "_")) initform &rest pipe-forms)
+(defmacro >> ((&key
+                 (prefix "_")
+                 (block (gensym ">>BLOCK-"))
+                 fail)
+              initform &rest pipe-forms)
   "Pipe a value through a series of forms and function calls. 
 
 For Example:
@@ -152,9 +156,12 @@ single pipe form."
             (string prefix)
             (symbol (symbol-name prefix)))))
     (labels ((var-p (v)
+               "A variable is a symbol that starts with PREFIX"
                (and (symbolp v)
                     (string= prefix (symbol-name v) :end2 (length prefix))))
              (pipe-form-p (form)
+               "A pipe form is either a symbol or a tree that contains
+                exactly one substitution variable, appearing one or more times."
                (or (symbolp form)
                    (let* ((vars
                             (remove-if-not #'var-p (flatten form)))
@@ -164,18 +171,41 @@ single pipe form."
                      (and (<= 1 vars-len)
                           ;; which all must be the same
                           (loop :for x :in (rest vars) :always (eql x (first vars)))))))
+             (escape-early-transform (forms)
+               "Tramsform the pipe forms to accomodate escape early checks."
+               (cond ((null forms) nil)
+                     ((and (eql :? (first forms))
+                           (second forms)
+                           (symbolp (second forms)))
+                      (cons `(if (funcall ',(second forms) ,(intern prefix))
+                                 ,(intern prefix) (return-from ,block ,fail))
+                            (escape-early-transform (cddr forms))))
+                     ((and (eql :? (first forms))
+                           (listp (second forms)))
+                      (let* ((form (second forms))
+                             (var (find-if #'var-p (flatten form))))
+                        (cons `(if ,form ,var (return-from ,block ,fail))
+                              (escape-early-transform (cddr forms)))))
+                     (t
+                      (cons (first forms)
+                            (escape-early-transform (rest forms))))))
              (folder (expansion form)
-               (let ((tmp (gensym)))
-                 `(let ((,tmp ,expansion)) 
-                    ,(etypecase form
-                       (cons  (subst-if tmp #'var-p form))
-                       (symbol `(funcall ',form ,tmp)))))))
+               "Expand the pipe forms."
+               (etypecase form
+                 (symbol `(funcall (function ,form) ,expansion))
+                 (cons
+                  (if (< 1 (count-if #'var-p (flatten form)))
+                      (let ((tmp (gensym "VAR-")))
+                        `(let ((,tmp ,expansion)) 
+                           ,(subst-if tmp #'var-p form)))
+                      (subst-if expansion #'var-p form))))))
       (assert (every #'pipe-form-p pipe-forms)
               ()
               "Invalid pipe form: ~s"
               (find-if-not #'pipe-form-p pipe-forms))
 
-      (reduce #'folder pipe-forms :initial-value initform))))
+      (list 'block block
+            (reduce #'folder (escape-early-transform pipe-forms) :initial-value initform)))))
 
 (defmacro binding-cond (&body clauses)
   "Like cond except the first form of every clause is a binding form