add test-call formHEADmaster

3 files changed, 49 insertions, 9 deletions

diff --git a/doc/mcgoron.srfi.64.scm b/doc/mcgoron.srfi.64.scm
index da0a8a4..05dccff 100644
--- a/doc/mcgoron.srfi.64.scm
+++ b/doc/mcgoron.srfi.64.scm
@@ -65,6 +65,13 @@ Set verbosity of the runner.
 
 If `value` is `fails`, then only report failures. Otherwise report failures
 and successes."))
+ ((name . "test-call")
+  (signature
+   syntax-rules ()
+   ((_ name (procedure args ...))))
+  (desc "
+Call `procedure` with `args` and test name `name`. The evaluated form of
+`procedure` and `args` are added to the test output."))
  ((name . "factory")
   (signature lambda () test-runner?)
   (desc "
diff --git a/mcgoron.srfi.64.scm b/mcgoron.srfi.64.scm
index 3a22ca8..c0d1e1d 100644
--- a/mcgoron.srfi.64.scm
+++ b/mcgoron.srfi.64.scm
@@ -94,8 +94,13 @@
   ;; 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.
+  ;; VERBOSITY is a list.
+  ;; 
+  ;; If VERBOSITY contains 'FAILS, then only failures are displayed.
+  ;; Otherwise all results are displayed.
+  ;; 
+  ;; If VERBOSITY contains 'GROUP-STACK, then the entire chain of groups
+  ;; is displayed.
   (aux group-information-queue
        displayables
        dynamic-properties
@@ -145,11 +150,8 @@
 (define (get-verbosity runner)
   (%get-verbosity (test-runner-aux-value runner)))
 
-(define (report-this-test? runner)
-  (let ((verbosity (get-verbosity runner)))
-    (if (test-passed? runner)
-        (not (eq? verbosity 'fails))
-        #t)))
+(define (verbosity-has runner value)
+  (memq 'fails (get-verbosity runner)))
 
 (define set-verbosity!
   (case-lambda
@@ -157,6 +159,23 @@
     ((runner value)
      (%set-verbosity! (test-runner-aux-value runner) value))))
 
+(define-syntax test-call
+  (syntax-rules ()
+    ((test-call name (%procedure %args ...))
+     (test-assert
+      name
+      (begin
+        (dynamic-property-set! 'form (quote (list %procedure %args ...)))
+        (let ((procedure %procedure)
+              (args (list %args ...)))
+          (dynamic-property-set! 'procedure procedure)
+          (dynamic-property-set! 'args args)
+          (apply procedure args)))))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Procedures for the test runner
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (define (wnl runner form)
   ;; Expand all forms with MAKE-DISPLAYABLE and pretty print FORM.
   (let ((form (make-displayable runner form)))
@@ -166,6 +185,18 @@
               (write form)
               (newline))))))
 
+(define (report-this-test? runner)
+  (if (test-passed? runner)
+      (not (verbosity-has runner 'fails))
+      #t))
+
+(define (maybe-write-stack runner)
+  ;; This function returns a list of list because it is spliced into
+  ;; the output.
+  (if (verbosity-has runner 'group-stack)
+      `((stack ,@(test-runner-group-stack runner)))
+      '()))
+
 (define (on-test-end runner)
   (let ((kind (test-result-kind runner))
         (aux (test-runner-aux-value runner)))
@@ -179,6 +210,7 @@
     (when (report-this-test? runner)
       (wnl runner
            `(test ,(test-runner-test-name runner)
+                  ,@(maybe-write-stack runner)
                   (result ,kind)
                   (properties ,@(get-dynamic-properties aux)
                               ,@(test-result-alist runner)))))
@@ -233,7 +265,7 @@
   (let ((runner (test-runner-null)))
     (test-runner-aux-value! runner
                             (aux '() *global-make-displayable* '()
-                                 'all))
+                                 '()))
     (test-runner-on-test-end! runner on-test-end)
     (test-runner-on-group-begin! runner on-group-begin)
     (test-runner-on-group-end! runner on-group-end)
diff --git a/mcgoron.srfi.64.sld b/mcgoron.srfi.64.sld
index 627d9bc..b02057d 100644
--- a/mcgoron.srfi.64.sld
+++ b/mcgoron.srfi.64.sld
@@ -23,5 +23,6 @@
    (else (import (scheme write))))
   (export factory set-displayable!
           dynamic-property-set!
-          get-verbosity set-verbosity!)
+          get-verbosity set-verbosity!
+          test-call)
   (include "mcgoron.srfi.64.scm"))