restructure

2 files changed, 103 insertions, 80 deletions

diff --git a/lib/conspire.scm b/lib/conspire.scm
index bc0ad5b..88d7272 100644
--- a/lib/conspire.scm
+++ b/lib/conspire.scm
@@ -92,42 +92,66 @@
 ;;; Manipulating the parameter object
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (call-with-name name thunk)
-  (define dict
-    (inspect-test-info
-     (lambda (dto dict)
-       (set! dict (dict-set! dto dict 'name name))
-       (if name
-           (dict-update/default! dto dict
-                                 'name-stack
-                                 (lambda (pair) (cons name pair))
-                                 '())
-           dict))))
-  (parameterize ((test-info (list 'replace dict)))
-    (thunk)))
-
 (define (call-as-test name thunk)
-  (when ((test-ref 'before-test) name)
-    (let ((thunk
-           (lambda ()
-             (call/cc
-              (lambda (return)
-                (define handle
-                  (let ((on-exception (test-ref 'on-exception))
-                        (return (lambda () (return #f))))
-                    (lambda (exn) (on-exception exn return))))
-                ((test-ref 'setup-test))
-                (with-exception-handler handle thunk)))
-             (inspect-test-info values))))
-      (call-with-values (lambda () (call-with-name name thunk))
-        (test-ref 'after-test)))))
+  (if ((test-ref 'skip-test?) name)
+      ((test-ref 'when-test-skipped) name)
+      (let ((thunk
+             (lambda ()
+               (call/cc
+                (lambda (return)
+                  (define handle
+                    (let ((on-exception (test-ref 'on-exception))
+                          (return (lambda () (return #f))))
+                      (lambda (exn) (on-exception exn return))))
+                  ((test-ref 'setup-test!) name)
+                  (with-exception-handler handle thunk)))
+               (inspect-test-info values))))
+        ((test-ref 'before-test!) name)
+        (call-with-values (lambda ()
+                            (parameterize ((test-info '(box)))
+                              (thunk)))
+          (test-ref 'after-test)))))
+
+(define (call-as-group name thunk)
+  (let ((inside (lambda ()
+                  ((test-ref 'setup-group!) name)
+                  (thunk)
+                  (inspect-test-info values))))
+    ((test-ref 'before-group!) name)
+    (call-with-values (lambda ()
+                        (parameterize ((test-info '(box)))
+                          (inside)))
+      (test-ref 'after-group))))
+
+(define (setup-name! name)
+  (test-set! 'name name)
+  (when name
+    (test-update/default! 'name-stack
+                          (lambda (x) (cons name x))
+                          '())))
 
 ;;; ;;;;;;;;;;
-;;; Default handlers
+;;; Default handlers for tests
 ;;; ;;;;;;;;;;
 
-(define (default-setup-test)
-  (test-delete! 'success?))
+(define (default-skip-test? name) #f)
+(define (default-before-test! name) #f)
+
+(define (default-setup-test! name)
+  (test-delete! 'success?)
+  (setup-name! name))
+
+(define (default-when-test-skipped name)
+  (test-update/default! 'skipped
+                        (lambda (x) (+ 1 x))
+                        0)
+  (test-update/default! 'tests
+                        (lambda (x) (+ x 1))
+                        0)
+  (display (string-append "SKIP        " (if name
+                                             (string-append "\"" name "\"")
+                                             "test")
+                          "\n")))
 
 (define (default-after-test previous-dto previous-test-info)
   (test-update/default! 'tests
@@ -168,20 +192,24 @@
          (newline))))
     (values previous-dto previous-test-info)))
 
-(define (default-before-test name)
-  #t)
+(define (default-on-exception exn return)
+  (test-set! 'success? #f)
+  (test-set! 'exception exn)
+  (return))
 
-(define (default-before-group name)
-  (if name
-      (display (string-append "entering group \"" name "\"\n"))
-      (display "entering group\n"))
-  #t)
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Default handlers for groups
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (default-setup-group name)
+(define (default-setup-group! name)
   (test-set! 'tests 0)
   (test-set! 'passed 0)
   (test-set! 'failed 0)
-  (test-set! 'skipped 0))
+  (test-set! 'skipped 0)
+  (setup-name! name))
+
+(define (default-before-group! name)
+  (display (string-append "ENTER    " (if name name "group") "\n")))
 
 (define (default-after-group previous-dto previous-info)
   (define (update/previous! name)
@@ -202,39 +230,38 @@
   (cond
     ((dict-ref previous-dto previous-info 'name)
      => (lambda (name)
-          (display (string-append "group \"" name "\" exited.\n"))))
-    (else (display "group exited.\n")))
+          (display (string-append "EXIT \"" name "\"\n"))))
+    (else (display "EXIT group\n")))
   (values previous-dto previous-info))
 
-(define (default-on-exception exn return)
-  (test-set! 'success? #f)
-  (test-set! 'exception exn)
-  (return))
-
 ;;; ;;;;;;;;;;;;;;;;
 ;;; test info
 ;;; ;;;;;;;;;;;;;;;;
 
 (define default-test-info-dict
-  `((before-test . ,default-before-test)
-    (setup-test . ,default-setup-test)
+  `((before-test! . ,default-before-test!)
+    (skip-test? . ,default-skip-test?)
+    (when-test-skipped . ,default-when-test-skipped)
+    (setup-test! . ,default-setup-test!)
     (after-test . ,default-after-test)
     (report-test . ,default-report-test)
-    (setup-group . ,default-setup-group)
+    (on-exception . ,default-on-exception)
+    (setup-group! . ,default-setup-group!)
     (after-group . ,default-after-group)
-    (before-group . ,default-before-group)
+    (before-group! . ,default-before-group!)
     (report-group . ,default-report-group)
-    (on-exception . ,default-on-exception)
     (passed . 0)
     (failed . 0)
     (skipped . 0)
-    (tests . 0)))
+    (tests . 0)
+    (name . #f)
+    (name-stack . ())))
 
-(define default-dto equal-alist-dto)
+(define default-test-info-dto equal-alist-dto)
 
 (define test-info
   (make-parameter
-   (list 'replace default-dto default-test-info-dict)
+   (list 'replace default-test-info-dto default-test-info-dict)
    (lambda (value)
      (cond
        ((not (pair? value))
@@ -338,22 +365,13 @@
      (call-as-test-error name error-predicate
                          (lambda () body ...)))))
 
-(define (call-as-group name thunk)
-  (when ((test-ref 'before-group) name)
-    (let ((inside (lambda ()
-                    ((test-ref 'setup-group) name)
-                    (thunk)
-                    (inspect-test-info values))))
-      (call-with-values (lambda () (call-with-name name inside))
-        (test-ref 'after-group)))))
-
 (define-syntax test-skip-all
   (syntax-rules ()
     ((_ body ...)
      (parameterize ((test-info
                      (list 'replace
-                           (test-set 'before-test
-                                     (lambda (_) #f)))))
+                           (test-set 'skip-test?
+                                     (lambda (_) #t)))))
        body ...))))
 
 (define-syntax test-group
diff --git a/lib/conspire.sld b/lib/conspire.sld
index 241ad1e..8aff22a 100644
--- a/lib/conspire.sld
+++ b/lib/conspire.sld
@@ -22,24 +22,29 @@
 
 (define-library (conspire)
   (import (scheme base) (scheme write) (scheme process-context) (srfi 225))
-  (export test-set! test-update! test-update/default!
-          test-contains?
-          test-ref test-ref/default
-          test-set test-update/default
-          test-delete!
-          test-info
-          call-with-name call-as-test
-          default-setup-test default-after-test default-before-test
-          default-report-test default-setup-group default-after-group
-          default-before-group default-report-group default-on-exception
-          default-test-info-dict default-dto
-          modify-test-info! inspect-test-info
+  (export conspire-error? conspire-error-message conspire-error-irritants
+          ;; test info
+          test-info test-info? modify-test-info! inspect-test-info
+          ;; test accessors and setters
+          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!
+          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-after-group default-report-group
+          default-test-info-dict default-test-info-dto
+          ;; SRFI-64 style assertions
           test-application with-test-assert
           test-equal test-eqv test-eq test-approximate
           call-as-test-error with-test-error
-          call-as-group test-group
-          with-test-group-cleanup
           test-skip-all
+          test-group
+          with-test-group-cleanup
           test-exit)
   (begin
     (define-record-type <conspire-error>