group hooks

2 files changed, 101 insertions, 64 deletions

diff --git a/lib/cuprate.scm b/lib/cuprate.scm
index deb84e1..72b74e6 100644
--- a/lib/cuprate.scm
+++ b/lib/cuprate.scm
@@ -61,33 +61,52 @@
 ;;; Manipulating the parameter object
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (call-as-test name thunk)
+(define (call/hooks before! setup! cleanup! skip? when-skipped after
+                    on-exception
+                    name thunk)
+  (define (body)
+    ;; This escapes the exception handler before attempting to re-raise
+    ;; the exception. This is to work around some bugs(?) in CHICKEN.
+    (call/cc
+     (lambda (return)
+       (define (handler ex)
+         (return (lambda ()
+                   (call/cc
+                    (lambda (return)
+                      ((test-ref on-exception) ex (lambda () (return #f)))
+                      (raise ex))))))
+       (with-exception-handler handler thunk)
+       (lambda () #f))))
   (define (exec)
-    ((test-ref 'before-test!) name)
+    ((test-ref before!) name)
     (parameterize ((test-info (test-info-dict)))
-      ((test-ref 'setup-test!) name)
-      (call/cc
-       (lambda (%return)
-         (define (return) (%return #f))
-         (with-exception-handler (lambda (ex)
-                                   ((test-ref 'on-exception) ex return)
-                                   (raise ex))
-           thunk)))
-      #;((test-ref 'cleanup-test!) name)
+      ((test-ref setup!) name)
+      ((body))
+      ((test-ref cleanup!) name)
       (test-info-dict)))
-  (if ((test-ref 'skip-test?) name)
-      ((test-ref 'when-test-skipped) name)
-      ((test-ref 'after-test) (exec))))
+  (if ((test-ref skip?) name)
+      ((test-ref when-skipped) name)
+      ((test-ref after) (exec))))
+
+(define (call-as-test name thunk)
+  (call/hooks 'before-test!
+              'setup-test!
+              'cleanup-test!
+              'skip-test?
+              'when-test-skipped
+              'after-test
+              'on-exception-in-test
+              name thunk))
 
 (define (call-as-group name thunk)
-  ;; TODO: Skipping groups.
-  (define (exec)
-    ((test-ref 'before-group!) name)
-    (parameterize ((test-info (test-info-dict)))
-      ((test-ref 'setup-group!) name)
-      (thunk)
-      (test-info-dict)))
-  ((test-ref 'after-group) (exec)))
+  (call/hooks 'before-group!
+              'setup-group!
+              'cleanup-group!
+              'skip-group?
+              'when-group-skipped
+              'after-group
+              'on-exception-in-group
+              name thunk))
 
 (define (setup-name! name)
   (test-set! 'name name)
@@ -106,6 +125,7 @@
 (define (default-setup-test! name)
   (test-delete! 'success?)
   (setup-name! name))
+(define (default-cleanup-test! name) #f)
 
 (define (default-when-test-skipped name)
   (test-update/default! 'skipped
@@ -173,23 +193,31 @@
        (display-report previous-test-info)))
     previous-test-info))
 
-(define (default-on-exception exn return)
-  (test-set! 'success? #f)
-  (test-set! 'exception exn)
+(define (default-on-exception-in-test exn return)
+  (test-set! 'success? #f 'exception exn)
   (return))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Default handlers for groups
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (default-setup-group! name)
-  (test-set! 'tests 0 'passed 0 'failed 0 'skipped 0)
-  (setup-name! name))
+(define (default-skip-group? name) #f)
+(define (default-when-group-skipped name)
+  (display (string-append "SKIP GROUP      "
+                          (if name
+                              (string-append "\"" name "\"")
+                              "")
+                          "\n")))
 
 (define (default-before-group! name)
   (when (test-ref/default 'verbose? #f)
     (display (string-append "ENTER    " (if name name "group") "\n"))))
 
+(define (default-setup-group! name)
+  (test-set! 'tests 0 'passed 0 'failed 0 'skipped 0)
+  (setup-name! name))
+(define (default-cleanup-group! name) #f)
+
 (define (default-after-group previous-info)
   (define (update/previous! name)
     (test-update/default!
@@ -199,10 +227,7 @@
                                         name
                                         0)))
      0))
-  (update/previous! 'tests)
-  (update/previous! 'passed)
-  (update/previous! 'failed)
-  (update/previous! 'skipped)
+  (for-each update/previous! '(tests passed failed skipped))
   ((test-ref 'report-group) previous-info))
 
 (define (default-report-group previous-info)
@@ -214,26 +239,37 @@
        => (lambda (name)
             (display (string-append "EXIT \"" name "\"\n"))))
       (else (display "EXIT group\n"))))
-
   previous-info)
 
+(define (default-on-exception-in-group ex return)
+  (error 'on-exception-in-group
+         "exception in group"
+         (test-ref 'name-stack)
+         (rewrite ex)))
+
 ;;; ;;;;;;;;;;;;;;;;
 ;;; test info
 ;;; ;;;;;;;;;;;;;;;;
 
 (define default-test-info-dict
   (alist->default-dictionary
-   `((before-test! . ,default-before-test!)
-     (skip-test? . ,default-skip-test?)
+   `((skip-test? . ,default-skip-test?)
      (when-test-skipped . ,default-when-test-skipped)
+     (before-test! . ,default-before-test!)
      (setup-test! . ,default-setup-test!)
+     (cleanup-test! . ,default-cleanup-test!)
      (after-test . ,default-after-test)
      (report-test . ,default-report-test)
-     (on-exception . ,default-on-exception)
+     (on-exception-in-test . ,default-on-exception-in-test)
+     ;; groups
+     (skip-group? . ,default-skip-group?)
+     (when-group-skipped . ,default-when-group-skipped)
+     (before-group! . ,default-before-group!)
      (setup-group! . ,default-setup-group!)
+     (cleanup-group! . ,default-cleanup-group!)
      (after-group . ,default-after-group)
-     (before-group! . ,default-before-group!)
      (report-group . ,default-report-group)
+     (on-exception-in-group . ,default-on-exception-in-group)
      (passed . 0)
      (failed . 0)
      (skipped . 0)
@@ -243,12 +279,14 @@
      (never-print-dto . ,equal-alist-dto)
      (pretty-print . ,pretty-print)
      (never-print . ,(map (lambda (x) (cons x x))
-                          '(before-test!
-                            skip-test? when-test-skipped setup-test!
-                            after-test report-test on-exception
-                            setup-group! after-group before-group!
-                            report-group never-print name rewriters
-                            never-print-dto pretty-print))))))
+                          '(skip-test? when-test-skipped before-test! setup-test!
+                                       cleanup-test! after-test report-test
+                                       on-exception-in-test
+                                       skip-group? when-group-skipped before-group!
+                                       setup-group! cleanup-group! after-group
+                                       report-group on-exception-in-group
+                                       never-print name rewriters
+                                       never-print-dto pretty-print))))))
 
 (define test-dto (make-parameter default-test-dto
                                  (lambda (x)
@@ -270,7 +308,7 @@
 
 (define-syntax test-application
   (syntax-rules ()
-    ((test-application test-name (name expr) ...)
+    ((_ test-name (name expr) ...)
      (call-as-test test-name (lambda ()
                                (test-set! 'form (quote (expr ...)))
                                (let ((name (let ((tmp expr))
@@ -323,22 +361,17 @@
                        (actual %actual)
                        (error %error)))))
 
-(define (call-as-test-error name error-predicate thunk)
-  (define (outer-thunk)
-    (test-set! 'success?
-               (call/cc
-                (lambda (return)
-                  (with-exception-handler (lambda (ex)
-                                            (test-set! 'exception ex)
-                                            (return (error-predicate ex)))
-                    (lambda () (thunk) #f))))))
-  (call-as-test name outer-thunk))
-
 (define-syntax test-error
   (syntax-rules ()
     ((_ name error-predicate body ...)
-     (call-as-test-error name error-predicate
-                         (lambda () body ...)))))
+     (test-body name
+       (let ((p error-predicate))
+         (test-set! 'on-exception-in-test
+                    (lambda (ex return)
+                      (test-set! 'success? (p ex))
+                      (return))))
+       (let () body ...)
+       #f))))
 
 (define-syntax expect-to-fail
   (syntax-rules ()
diff --git a/lib/cuprate.sld b/lib/cuprate.sld
index a032db5..9b7e166 100644
--- a/lib/cuprate.sld
+++ b/lib/cuprate.sld
@@ -8,22 +8,26 @@
    test-set! test-update! test-update/default! test-delete!
    test-contains? test-ref test-ref/default test-set
    test-update/default
-   call-as-test call-as-group
    ;; Default test procedures
    setup-name! display-report
-   default-skip-test? default-before-test! default-setup-test!
-   default-when-test-skipped default-after-test default-report-test
-   default-on-exception
-   default-setup-group! default-before-group!
+   default-skip-test? default-when-test-skipped
+   default-before-test! default-setup-test! default-cleanup-test!
+   default-after-test default-report-test
+   default-on-exception-in-test
+   default-skip-group? default-when-group-skipped
+   default-before-group! default-setup-group! default-cleanup-group!
    default-after-group default-report-group
+   default-on-exception-in-group
    ;; SRFI-64 style assertions
+   call-as-test call-as-group
    test-application test-body
    test-equal test-eqv test-eq test-approximate
-   call-as-test-error test-error expect-to-fail
+   test-error expect-to-fail
    test-skip-all
    test-group
    with-test-group-cleanup
-   test-exit)
+   test-exit
+   pretty-print)
   (begin
     (define-record-type <test-info>
       (wrap-test-info dict)