Keep going upon errors in tests. Use env vars.

`MYRA_INTERACTIVE_DEBUGGING' and `MYRA_STOP_ON_EXCEPTION' can now be set in the
environment of the program to control what it does in case of error in a test.

1 files changed, 36 insertions, 20 deletions

diff --git a/src/guile/myra-test-utils.scm b/src/guile/myra-test-utils.scm
index 4342539..8f6a3c8 100644
--- a/src/guile/myra-test-utils.scm
+++ b/src/guile/myra-test-utils.scm
@@ -11,7 +11,6 @@
   #:use-module ((ice-9 match) #:select (match))
   #:use-module ((system repl error-handling)
                 #:select (call-with-error-handling))
-  #:re-export ((srfi-64:test-group . test-group))
   #:export (%interactive-debugging
 
             test-assert
@@ -21,35 +20,48 @@
             test-approximate
             test-error
 
+            test-group
+
             call-with-fixtures
             with-fixtures
             test-group-with-fixtures))
 
 (define %interactive-debugging
-  (make-parameter #f))
+  (make-parameter (not (not (getenv "MYRA_INTERACTIVE_DEBUGGING")))))
+
+(define %stop-on-exception
+  (make-parameter (not (not (getenv "MYRA_STOP_ON_EXCEPTION")))))
 
-(define (wrap-call thunk)
+(define (*wrap-expr thunk)
   (if (%interactive-debugging)
       (call-with-error-handling thunk)
       (thunk)))
 
-(define-syntax-rule (wrap test-expr)
-  (wrap-call (lambda () test-expr)))
+(define (*wrap-test thunk)
+  (if (%stop-on-exception)
+      (thunk)
+      (false-if-exception (thunk))))
+
+(define-syntax-rule (wrap-expr test-expr)
+  (*wrap-expr (lambda () test-expr)))
+
+(define-syntax-rule (wrap-test test)
+  (*wrap-test (lambda () test)))
 
 (define-syntax-rule (test-assert stuff ... test-expr)
-  (srfi-64:test-assert stuff ... (wrap test-expr)))
+  (wrap-test (srfi-64:test-assert stuff ... (wrap-expr test-expr))))
 
 (define-syntax-rule (test-eq stuff ... test-expr)
-  (srfi-64:test-eq stuff ... (wrap test-expr)))
+  (wrap-test (srfi-64:test-eq stuff ... (wrap-expr test-expr))))
 
 (define-syntax-rule (test-eqv stuff ... test-expr)
-  (srfi-64:test-eqv stuff ... (wrap test-expr)))
+  (wrap-test (srfi-64:test-eqv stuff ... (wrap-expr test-expr))))
 
 (define-syntax-rule (test-equal stuff ... test-expr)
-  (srfi-64:test-equal stuff ... (wrap test-expr)))
+  (wrap-test (srfi-64:test-equal stuff ... (wrap-expr test-expr))))
 
 (define-syntax-rule (test-approximate stuff ... test-expr error)
-  (srfi-64:test-approximate stuff ... (wrap test-expr) error))
+  (wrap-test (srfi-64:test-approximate stuff ... (wrap-expr test-expr) error)))
 
 (define %exception-object-indicator
   (gensym))
@@ -58,16 +70,17 @@
   (match (let/ec escape
            (guard (unexpected-ex (#t
                                   (escape unexpected-ex)))
-             (wrap-call (lambda ()
-                          (guard (ex
-                                  ((or (and (condition-type? error-type)
-                                            (condition-has-type? ex error-type))
-                                       (and (procedure? error-type)
-                                            (error-type ex))
-                                       (eq? error-type #t))
-                                   (escape (list %exception-object-indicator
-                                                 ex))))
-                            (const (thunk)))))))
+             (*wrap-expr (lambda ()
+                           (guard (ex
+                                   ((or (and (condition-type? error-type)
+                                             (condition-has-type?
+                                              ex error-type))
+                                        (and (procedure? error-type)
+                                             (error-type ex))
+                                        (eq? error-type #t))
+                                    (escape (list %exception-object-indicator
+                                                  ex))))
+                             (const (thunk)))))))
     (((? (cut eq? %exception-object-indicator <>)) ex)
      (raise ex))
     (result
@@ -81,6 +94,9 @@
      (srfi-64:test-error stuff ... #t
                          (except-error error-type (lambda () test-expr))))))
 
+(define-syntax-rule (test-group stuff ...)
+  (wrap-test (srfi-64:test-group stuff ...)))
+
 (define (call-with-fixtures fixtures thunk)
   (match fixtures
     (()