add on-error!

3 files changed, 54 insertions, 11 deletions

diff --git a/cond-thunk.egg b/cond-thunk.egg
index 9432057..1472c7f 100644
--- a/cond-thunk.egg
+++ b/cond-thunk.egg
@@ -1,5 +1,5 @@
 ((author "Peter McGoron")
- (version "0.1.0")
+ (version "0.2.0")
  (synopsis "macros for abstracting conditional branches")
  (category "lang-exts")
  (license "Apache-2.0")
diff --git a/mcgoron.cond-thunk.values.scm b/mcgoron.cond-thunk.values.scm
index 7ca5236..feb345b 100644
--- a/mcgoron.cond-thunk.values.scm
+++ b/mcgoron.cond-thunk.values.scm
@@ -21,18 +21,33 @@
     ((cond-values clauses ...)
      (cond-thunk clauses ... (else (values))))))
 
-(define-syntax after
-  (syntax-rules (when let =>)
-    ((after ((when conditional) clauses ...) body ...)
+(define-syntax %after
+  (syntax-rules (on-fail! %lambda %body when let =>)
+    ((_ old-abort %lambda ((on-fail! on-error) clauses ...) body ...)
+     (lambda ()
+       (let ((abort (lambda () on-error)))
+         (%after abort %body (clauses ...) body ...))))
+    ((_ old-abort %body ((on-fail! on-error) clauses ...) body ...)
+     (let ((abort (lambda () on-error)))
+       (%after abort %body (clauses ...) body ...)))
+    ((_ abort action ((when conditional) clauses ...) body ...)
      (if conditional
-         (after (clauses ...) body ...)
-         #f))
-    ((after ((let value => formal) clauses ...) body ...)
+         (%after abort action (clauses ...) body ...)
+         (abort)))
+    ((_ abort action ((let value => formal) clauses ...) body ...)
      (case-receive value
-       (() #f)
-       (formal (after (clauses ...) body ...))))
-    ((after () body ...)
-     (lambda () body ...))))
+       (() (abort))
+       (formal (%after abort action (clauses ...) body ...))))
+    ((_ abort %lambda () body ...)
+     (lambda () body ...))
+    ((_ abort %body () body ...)
+     (begin body ...))))
+
+(define-syntax after
+  (syntax-rules ()
+    ((after (clauses ...) body ...)
+     (let ((abort (lambda () #f)))
+       (%after abort %lambda (clauses ...) body ...)))))
 
 (define-syntax apply-after
   (syntax-rules ()
diff --git a/tests/values.scm b/tests/values.scm
index f1d63f7..cafa8b0 100644
--- a/tests/values.scm
+++ b/tests/values.scm
@@ -108,6 +108,34 @@
     (test-assert "length-at-least=> 3.4" (equal? rest '(4))))
   (else (error "length-at-least=> 3" #f)))
 
+(test "on-fail 1"
+      5
+      (cond-thunk
+        (after ((when #t)
+                (on-fail! 5)
+                (when #f))
+          'no-fail)
+        (else 'else)))
+
+(test "on-fail 2"
+      'caught
+      (guard (x ((eq? x 'throw) 'caught) (else 'something-else))
+        (cond-thunk
+          (after ((when #t)
+                  (on-fail! (raise 'throw))
+                  (when #f))
+            'no-failed)
+          (else 'else))))
+
+(test "on-fail 3"
+      'no-fail
+      (cond-thunk
+        (after ((on-fail! 'fail1)
+                (when #t)
+                (on-fail! 'fail2))
+          'no-fail)
+        (else 'else)))
+
 (define-syntax with-catch-predicate
   (syntax-rules ()
     ((with-catch-predicate predicate? body ...)