rename

5 files changed, 196 insertions, 50 deletions

diff --git a/README.md b/README.md
index aa34c53..709e75a 100644
--- a/README.md
+++ b/README.md
@@ -1,9 +1,5 @@
-A test runner that writes s-expressions to the default output port.
-
-Since some expressions are not printable by default (like records),
-this library offers `(add-displayable! predicate transformer)`,
-which will apply `transformer` to any value that satisfies `predicate`
-in that test runner. This will override any previous operation.
+A test runner that writes s-expressions to the default output port. Read
+the documentation for more information.
 
 To use, just import `(mcgoron srfi 64)` and use `(factory)` to make a new
 test runner.
diff --git a/doc/mcgoron.srfi.64.scm b/doc/mcgoron.srfi.64.scm
new file mode 100644
index 0000000..da0a8a4
--- /dev/null
+++ b/doc/mcgoron.srfi.64.scm
@@ -0,0 +1,71 @@
+(((name . "set-displayable!")
+  (signature
+   case-lambda
+   (((procedure? predicate?) (procedure? transformer)) *)
+   (((test-runner? runner) (procedure? predicate?) (procedure? transformer)) *))
+  (subsigs
+   (predicate? (lambda (*) boolean?))
+   (transformer (lambda ((test-runner? runner) (predicate? value)) *)))
+  (desc "
+Adds a new display transformer to the test runner. If no test runner is
+specified, adds a new display transformer to the current test runner.
+
+For information about how the test runner transforms values, see the
+documentation for `make-displayable`.
+
+The use of this function in conjunction with `make-displayable` makes it
+possible to rewrite recursive structures. For example, to translate a
+custom record type for the current test runner:
+
+    (define-record-type <my-record-type>
+       (my-record-type field1 field2)
+       my-record-type?
+       (field1 get-field1)
+       (field2 get-field2))
+
+    (set-displayable! my-record-type?
+                      (lambda (runner value)
+                        (list '<my-record-type>
+                              (make-displayable runner (get-field1 value))
+                              (make-displayable runner (get-field2 value)))))
+"))
+ ((name . "make-displayable")
+  (signature lambda ((test-runner? runner) value) *)
+  (desc "
+Attempts to make `value` displayable using the display transformers in
+`runner`.
+
+Whenever test results are written to the screen, the list of display
+transformers for that test runner are used to rewrite the test results to
+be writeable using `write`. This is used to make normally unprintable
+values such as `define-record-type` records printable.
+
+Whenever `make-displayable` is called with a value,
+the `predicate?` of each transformer in `runner` is checked, newest first,
+and if any of the `predicate?` procedures return true, the `transformer`
+procedure is called with the runner as the first argument and the value
+as the second argument.
+"))
+ ((name . "dynamic-property-set!")
+  (signature
+   case-lambda
+   ((property value) *)
+   (((test-runner? runner) property value) *))
+  (desc "
+Add `(cons property value)` to the dynamic property alist of runner. The
+dynamic properties of the runner are printed out at the end of a run and
+are discarded after the end of a test."))
+ ((name . "set-verbosity!")
+  (signature
+   case-lambda
+   ((value) *)
+   (((test-runner? runner) value *)))
+  (desc "
+Set verbosity of the runner.
+
+If `value` is `fails`, then only report failures. Otherwise report failures
+and successes."))
+ ((name . "factory")
+  (signature lambda () test-runner?)
+  (desc "
+An SRFI-64 factory, suitable for passing to `test-runner-factory`.")))
\ No newline at end of file
diff --git a/mcgoron.srfi.64.scm b/mcgoron.srfi.64.scm
index 287c6c5..23cb179 100644
--- a/mcgoron.srfi.64.scm
+++ b/mcgoron.srfi.64.scm
@@ -15,14 +15,18 @@
  |#
 
 (define *global-make-displayable*
+  ;; The list of default container objects that are traversed using
+  ;; MAKE-DISPLAYABLE.
   (list
    (cons pair?
-         (lambda (value)
-           (cons (make-displayable (car value))
-                 (make-displayable (cdr value)))))
+         (lambda (runner value)
+           (cons (make-displayable runner (car value))
+                 (make-displayable runner (cdr value)))))
    (cons vector?
-         (lambda (value)
-           (vector-map make-displayable value)))
+         (lambda (runner value)
+           (vector-map (lambda (value)
+                         (make-displayable runner value))
+                       value)))
    (cons eof-object?
          (lambda (_)
            `(an-eof-object)))))
@@ -30,14 +34,28 @@
 (cond-expand
  (chicken
   (set! *global-make-displayable*
+        ;; Handle chicken condition objects.
         (cons
          (cons condition?
-               (lambda (value)
-                 (make-displayable (condition->list value))))
+               (lambda (runner value)
+                 (make-displayable runner (condition->list value))))
          *global-make-displayable*)))
  (else))
 
+(define set-displayable!
+  (case-lambda
+    ((predicate? transformer) (set-displayable! (test-runner-current)
+                                                predicate?
+                                                transformer))
+    ((runner predicate? transformer)
+     (let ((aux (test-runner-aux-value runner)))
+       (%set-displayables! aux
+                           (cons (cons predicate? transformer)
+                                 (get-displayables aux)))))))
+
 (define (make-displayable runner value)
+  ;; Uses the DISPLAYABLES in RUNNER to transform VALUE into something
+  ;; that is easier to print.
   (let loop ((lst (get-displayables (test-runner-aux-value runner))))
     (if (null? lst)
         value
@@ -45,12 +63,29 @@
                (predicate? (car pair))
                (transformer (cdr pair)))
           (if (predicate? value)
-              (transformer value)
+              (transformer runner value)
               (loop (cdr lst)))))))
 
 (define-record-type <aux>
-  (aux tests-passed-in-group tests-failed-in-group tests-skipped-in-group
-       displayables)
+  ;; Auxillary data stored in the test runner.
+  ;; Counts the number of tests passed or failed in a group (Because the
+  ;; reference implementation does not do this).
+  ;; 
+  ;; DISPLAYABLES is the list of display transformers. It is carried
+  ;; through all tests.
+  ;; 
+  ;; 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
+       displayables
+       dynamic-properties
+       verbosity)
   aux?
   (tests-passed-in-group get-tests-passed-in-group
                          set-tests-passed-in-group!)
@@ -58,9 +93,51 @@
                          set-tests-failed-in-group!)
   (tests-skipped-in-group get-tests-skipped-in-group
                           set-tests-skipped-in-group!)
-  (displayables get-displayables set-displayables!))
+  (displayables get-displayables %set-displayables!)
+  (dynamic-properties get-dynamic-properties set-dynamic-properties!)
+  (verbosity %get-verbosity %set-verbosity!))
+
+(define dynamic-property-set!
+  (let ((dynamic-property-set!
+         (lambda (runner property value)
+           (let* ((aux (test-runner-aux-value runner))
+                  (old (get-dynamic-properties aux)))
+             (set-dynamic-properties! aux
+                                      (cons (cons property value)
+                                            old))))))
+    (case-lambda
+      ((property value) (dynamic-property-set! (test-runner-current)
+                                               property
+                                               value))
+      ((runner property value) (dynamic-property-set! runner
+                                                      property
+                                                      value)))))
+
+(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 (on-test-begin runner)
+(define set-verbosity!
+  (case-lambda
+    ((value) (set-verbosity! (test-runner-current) value))
+    ((runner value)
+     (%set-verbosity! (test-runner-aux-value runner) value))))
+
+(define (wnl runner form)
+  ;; Expand all forms with MAKE-DISPLAYABLE and pretty print FORM.
+  (let ((form (make-displayable runner form)))
+    (cond-expand
+      (chicken (pretty-print form))
+      (else (begin
+              (write form)
+              (newline))))))
+
+(define (on-test-end runner)
   (let ((kind (test-result-kind runner))
         (aux (test-runner-aux-value runner)))
     (cond
@@ -76,33 +153,36 @@
        (set-tests-failed-in-group! aux
                                    (+ 1
                                       (get-tests-failed-in-group aux)))))
-    (write `(test ,(test-runner-test-name runner)
+    (when (report-this-test? runner)
+      (wnl runner
+           `(test ,(test-runner-test-name runner)
                   (result ,kind)
-                  (properties ,@(test-result-alist runner))))
-    (newline)))
+                  (properties ,@(get-dynamic-properties aux)
+                              ,@(test-result-alist runner)))))
+    (set-dynamic-properties! aux '())))
 
 (define (on-group-begin runner suite-name count)
-  (write `(start ,suite-name))
-  (newline))
+  (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)))
-    (write `(end (passed ,passed)
-                 (failed ,failed)
-                 (skipped ,skipped)
-                 (tests ,(+ passed failed skipped))))
-    (newline)
+    (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)))
 
 (define (on-bad-count runner actual expected)
-  (write `(warning expected ,expected
-                   got ,actual))
-  (newline))
+  (wnl runner
+       `(warning expected ,expected
+                 got ,actual)))
 
 (define (on-bad-end-name runner begin-name end-name)
   (error "mismatch in test names" begin-name end-name
@@ -110,25 +190,20 @@
          runner))
 
 (define (on-final runner)
-  (write `(summary
-           (pass (expected ,(test-runner-pass-count runner))
-                 (not-expected ,(test-runner-xpass-count runner)))
-           (fail (not-expected ,(test-runner-fail-count runner))
-                 (expected ,(test-runner-xfail-count runner)))
-           (skipped ,(test-runner-skip-count runner)))))
-
-(define (add-displayable! runner predicate transformer)
-  (let* ((aux (test-runner-aux-value runner))
-         (previous (get-displayables runner)))
-    (set-displayables! aux
-                       (cons (cons predicate transformer)
-                             previous))))
+  (wnl runner
+       `(summary
+         (pass (expected ,(test-runner-pass-count runner))
+               (not-expected ,(test-runner-xpass-count runner)))
+         (fail (not-expected ,(test-runner-fail-count runner))
+               (expected ,(test-runner-xfail-count runner)))
+         (skipped ,(test-runner-skip-count runner)))))
 
 (define (factory)
   (let ((runner (test-runner-null)))
     (test-runner-aux-value! runner
-                            (aux 0 0 0 *global-make-displayable*))
-    (test-runner-on-test-begin! runner on-test-begin)
+                            (aux 0 0 0 *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)
     (test-runner-on-bad-end-name! runner on-bad-end-name)
diff --git a/mcgoron.srfi.64.sld b/mcgoron.srfi.64.sld
index 5bafb37..627d9bc 100644
--- a/mcgoron.srfi.64.sld
+++ b/mcgoron.srfi.64.sld
@@ -15,9 +15,13 @@
  |#
 
 (define-library (mcgoron srfi 64)
-  (import (scheme base) (scheme write) (srfi 64))
+  (import (scheme base)
+          (scheme case-lambda)
+          (srfi 64))
   (cond-expand
-   (chicken (import (chicken condition)))
-   (else))
-  (export factory add-displayable!)
+   (chicken (import (chicken condition) (chicken pretty-print)))
+   (else (import (scheme write))))
+  (export factory set-displayable!
+          dynamic-property-set!
+          get-verbosity set-verbosity!)
   (include "mcgoron.srfi.64.scm"))
diff --git a/mcgoron-srfi-64.egg b/sexpr-srfi-64-runner.egg
index aecbeef..aecbeef 100644
--- a/mcgoron-srfi-64.egg
+++ b/sexpr-srfi-64-runner.egg