fix nested groups

1 files changed, 60 insertions, 29 deletions

diff --git a/mcgoron.srfi.64.scm b/mcgoron.srfi.64.scm
index 23cb179..3a22ca8 100644
--- a/mcgoron.srfi.64.scm
+++ b/mcgoron.srfi.64.scm
@@ -66,37 +66,66 @@
               (transformer runner value)
               (loop (cdr lst)))))))
 
-(define-record-type <aux>
-  ;; Auxillary data stored in the test runner.
+(define-record-type <group-information>
   ;; Counts the number of tests passed or failed in a group (Because the
   ;; reference implementation does not do this).
+  (group-information tests-passed-in-group
+                     tests-failed-in-group
+                     tests-skipped-in-group)
+  group-information?
+  (tests-passed-in-group get-tests-passed-in-group
+                         set-tests-passed-in-group!)
+  (tests-failed-in-group get-tests-failed-in-group
+                         set-tests-failed-in-group!)
+  (tests-skipped-in-group get-tests-skipped-in-group
+                          set-tests-skipped-in-group!))
+
+(define-record-type <aux>
+  ;; Auxillary data stored in the test runner.
   ;; 
   ;; DISPLAYABLES is the list of display transformers. It is carried
   ;; through all tests.
   ;; 
+  ;; GROUP-INFORMATION-QUEUE is a list consisting of all information about
+  ;; tests passed and failed in a group. When an element is popped the
+  ;; stats are added to the next-in-line.
+  ;; 
   ;; DYNAMIC-PROPERTIES is a property alist that can be modified by the
   ;; testing program (test-result-set! only works in implementation or
   ;; in runner code). They are reset at the end of each test.
   ;; 
   ;; VERBOSITY is a symbol. If VERBOSITY is "fails", then only failures
   ;; are displayed. Otherwise all results are displayed.
-  (aux tests-passed-in-group
-       tests-failed-in-group
-       tests-skipped-in-group
+  (aux group-information-queue
        displayables
        dynamic-properties
        verbosity)
   aux?
-  (tests-passed-in-group get-tests-passed-in-group
-                         set-tests-passed-in-group!)
-  (tests-failed-in-group get-tests-failed-in-group
-                         set-tests-failed-in-group!)
-  (tests-skipped-in-group get-tests-skipped-in-group
-                          set-tests-skipped-in-group!)
+  (group-information-queue get-group-queue set-group-queue!)
   (displayables get-displayables %set-displayables!)
   (dynamic-properties get-dynamic-properties set-dynamic-properties!)
   (verbosity %get-verbosity %set-verbosity!))
 
+(define (add-to-tests-in-group! op aux num)
+  (define (getter op)
+    (case op
+      ((skipped) get-tests-skipped-in-group)
+      ((passed) get-tests-passed-in-group)
+      ((failed) get-tests-failed-in-group)
+      (else (error "invalid getter" op))))
+  (define (setter op)
+    (case op
+      ((skipped) set-tests-skipped-in-group!)
+      ((passed) set-tests-passed-in-group!)
+      ((failed) set-tests-failed-in-group!)
+      (else (error "invalid setter" op))))
+  (let ((queue (get-group-queue aux)))
+    (when (not (null? queue))
+      (let ((group (car queue))
+            (set (setter op))
+            (get (getter op)))
+        (set group (+ num (get group)))))))
+
 (define dynamic-property-set!
   (let ((dynamic-property-set!
          (lambda (runner property value)
@@ -142,17 +171,11 @@
         (aux (test-runner-aux-value runner)))
     (cond
       ((eq? kind 'skip)
-       (set-tests-skipped-in-group! aux
-                                    (+ 1
-                                       (get-tests-skipped-in-group aux))))
+       (add-to-tests-in-group! 'skipped aux 1))
       ((test-passed? runner)
-       (set-tests-passed-in-group! aux
-                                   (+ 1
-                                      (get-tests-passed-in-group aux))))
+       (add-to-tests-in-group! 'passed aux 1))
       (else
-       (set-tests-failed-in-group! aux
-                                   (+ 1
-                                      (get-tests-failed-in-group aux)))))
+       (add-to-tests-in-group! 'failed aux 1)))
     (when (report-this-test? runner)
       (wnl runner
            `(test ,(test-runner-test-name runner)
@@ -162,22 +185,30 @@
     (set-dynamic-properties! aux '())))
 
 (define (on-group-begin runner suite-name count)
-  (wnl runner
-       `(start ,suite-name)))
+  (let ((aux (test-runner-aux-value runner)))
+    (set-group-queue! aux
+                      (cons (group-information 0 0 0)
+                            (get-group-queue aux))))
+  (wnl runner `(start ,suite-name)))
 
 (define (on-group-end runner)
   (let* ((aux (test-runner-aux-value runner))
-         (passed (get-tests-passed-in-group aux))
-         (failed (get-tests-failed-in-group aux))
-         (skipped (get-tests-skipped-in-group aux)))
+         (current-group (car (get-group-queue aux)))
+         (passed (get-tests-passed-in-group current-group))
+         (failed (get-tests-failed-in-group current-group))
+         (skipped (get-tests-skipped-in-group current-group)))
     (wnl runner
          `(end (passed ,passed)
                (failed ,failed)
                (skipped ,skipped)
                (tests ,(+ passed failed skipped))))
-    (set-tests-passed-in-group! aux 0)
-    (set-tests-failed-in-group! aux 0)
-    (set-tests-skipped-in-group! aux 0)))
+    (let ((next-group-queue (cdr (get-group-queue aux))))
+      (set-group-queue! aux next-group-queue)
+      (when (not (null? next-group-queue))
+        (let ((next-group (car next-group-queue)))
+          (add-to-tests-in-group! 'passed aux passed)
+          (add-to-tests-in-group! 'skipped aux skipped)
+          (add-to-tests-in-group! 'failed aux failed))))))
 
 (define (on-bad-count runner actual expected)
   (wnl runner
@@ -201,7 +232,7 @@
 (define (factory)
   (let ((runner (test-runner-null)))
     (test-runner-aux-value! runner
-                            (aux 0 0 0 *global-make-displayable* '()
+                            (aux '() *global-make-displayable* '()
                                  'all))
     (test-runner-on-test-end! runner on-test-end)
     (test-runner-on-group-begin! runner on-group-begin)