add expect-to-fail

4 files changed, 28 insertions, 5 deletions

diff --git a/README.md b/README.md
index 0d2405a..7250ebc 100644
--- a/README.md
+++ b/README.md
@@ -170,6 +170,11 @@ Evaluates `body ...` in a test. This test will set
 * `success?`: False if evaluation does not throw an exception. Otherwise
   the return value of `error-predicate` on the thrown exception.
 
+    (expect-to-fail body ...) ; syntax
+
+Execute all tests in `body ...`, reporting a success if they fail and
+reporting a failure if the succeed.
+
 ## Porting Guide
 
 This library requires `make-parameter` and `parameterize` to work like
diff --git a/lib/conspire.scm b/lib/conspire.scm
index 7d8bfcd..130218f 100644
--- a/lib/conspire.scm
+++ b/lib/conspire.scm
@@ -389,12 +389,25 @@
                     (lambda () (thunk) #f))))))
   (call-as-test name outer-thunk))
 
-(define-syntax with-test-error
+(define-syntax test-error
   (syntax-rules ()
     ((_ name error-predicate body ...)
      (call-as-test-error name error-predicate
                          (lambda () body ...)))))
 
+(define-syntax expect-to-fail
+  (syntax-rules ()
+    ((_ body ...)
+     (let ((outer-after-test (test-ref 'after-test)))
+       (test-group #f
+         (test-set! 'after-test
+                    (lambda (dto dict)
+                      (outer-after-test dto
+                                        (dict-update! dto dict
+                                                      'success?
+                                                      not))))
+         (let () body ...))))))
+
 (define-syntax test-skip-all
   (syntax-rules ()
     ((_ body ...)
diff --git a/lib/conspire.sld b/lib/conspire.sld
index 430a2a7..0b50d94 100644
--- a/lib/conspire.sld
+++ b/lib/conspire.sld
@@ -41,7 +41,7 @@
           ;; SRFI-64 style assertions
           test-application test-assert
           test-equal test-eqv test-eq test-approximate
-          call-as-test-error with-test-error
+          call-as-test-error test-error expect-to-fail
           test-skip-all
           test-group
           with-test-group-cleanup
diff --git a/tests/impl.scm b/tests/impl.scm
index 6783dd9..0395fb2 100644
--- a/tests/impl.scm
+++ b/tests/impl.scm
@@ -421,7 +421,7 @@
   (test-assert "thrown exception"
     (define-values (dto dict)
       (parameterize ((test-info (list 'replace default-test-info-dto silent-dict)))
-        (with-test-error #f
+        (test-error #f
           (lambda (ex) (equal? ex "exception"))
           (raise "exception"))
         (inspect-test-info values)))
@@ -429,7 +429,7 @@
   (test-assert "no thrown exception"
     (define-values (dto dict)
       (parameterize ((test-info (list 'replace default-test-info-dto silent-dict)))
-        (with-test-error #f
+        (test-error #f
           (lambda (ex) #t)
           #f)
         (inspect-test-info values)))
@@ -437,8 +437,13 @@
   (test-assert "incorrectly thrown exception"
     (define-values (dto dict)
       (parameterize ((test-info (list 'replace default-test-info-dto silent-dict)))
-        (with-test-error #f number? (raise "exception"))
+        (test-error #f number? (raise "exception"))
         (inspect-test-info values)))
     (eqv? 1 (dict-ref dto dict 'failed))))
 
+(test-group "expect-to-fail"
+  (expect-to-fail
+    (test-assert "1 = 2" (eqv? 1 2))
+    (test-assert "type error" (car '()))))
+
 (test-exit)