add adjustable value rewriter

5 files changed, 135 insertions, 25 deletions

diff --git a/conspire.egg b/conspire.egg
index ece198f..53792af 100644
--- a/conspire.egg
+++ b/conspire.egg
@@ -1,11 +1,12 @@
 ((author "Peter McGoron")
  (version "0.1.0")
- (synopsis "A R6RS/R7RS testing suite")
+ (synopsis "A modern testing suite")
  (category "test")
  (license "MIT")
  (dependencies "r7rs" "srfi-18" "srfi-225")
  (components (extension conspire
                (source "lib/conspire.sld")
                (source-dependencies "lib/conspire.scm"
-                                    "lib/r7rs-srfi-18.scm")
+                                    "lib/r7rs-srfi-18.scm"
+                                    "lib/rewriters.chicken.scm")
                (csc-options "-R" "r7rs" "-X" "r7rs"))))
diff --git a/lib/conspire.scm b/lib/conspire.scm
index 1627ed1..549bf11 100644
--- a/lib/conspire.scm
+++ b/lib/conspire.scm
@@ -166,6 +166,22 @@
                           0)
     ((test-ref 'report-test) previous-dto previous-test-info)))
 
+(define (display-report previous-dto previous-dict)
+  (let ((never-print-dto (dict-ref previous-dto previous-dict
+                                   'never-print-dto))
+        (never-print (dict-ref previous-dto previous-dict
+                               'never-print)))
+    (dict-for-each previous-dto
+                   (lambda (key value)
+                     (unless (dict-contains? never-print-dto
+                                             never-print
+                                             key)
+                       (display (test-rewrite key))
+                       (display ": ")
+                       (display (test-rewrite value))
+                       (newline)))
+                   previous-dict)))
+
 (define (default-report-test previous-dto previous-test-info)
   (let ((verbose? (test-ref/default 'verbose? #f))
         (specifically-verbose? (dict-ref/default previous-dto
@@ -182,14 +198,10 @@
     (cond
       (success?
        (when (or verbose? specifically-verbose?)
-         (display (string-append "success:           \"" name "\"\n"))))
+         (display (string-append "PASS:           \"" name "\"\n"))
+         (display-report previous-dto previous-test-info)))
       (else
-       (display (string-append "FAILED:           \"" name "\"\n"))
-       (when (dict-contains? previous-dto previous-test-info 'exception)
-         (display (list 'exception (dict-ref previous-dto
-                                             previous-test-info
-                                             'exception)))
-         (newline))))
+       (display (string-append "FAIL:           \"" name "\"\n"))))
     (values previous-dto previous-test-info)))
 
 (define (default-on-exception exn return)
@@ -209,7 +221,8 @@
   (setup-name! name))
 
 (define (default-before-group! name)
-  (display (string-append "ENTER    " (if name name "group") "\n")))
+  (when (test-ref/default 'verbose? #f)
+    (display (string-append "ENTER    " (if name name "group") "\n"))))
 
 (define (default-after-group previous-dto previous-info)
   (define (update/previous! name)
@@ -227,11 +240,15 @@
   ((test-ref 'report-group) previous-dto previous-info))
 
 (define (default-report-group previous-dto previous-info)
-  (cond
-    ((dict-ref previous-dto previous-info 'name)
-     => (lambda (name)
-          (display (string-append "EXIT \"" name "\"\n"))))
-    (else (display "EXIT group\n")))
+  (when (or (test-ref/default 'verbose? #f)
+            (dict-ref/default previous-dto previous-info
+                              'verbose? #f))
+    (cond
+      ((dict-ref previous-dto previous-info 'name)
+       => (lambda (name)
+            (display (string-append "EXIT \"" name "\"\n"))))
+      (else (display "EXIT group\n"))))
+
   (values previous-dto previous-info))
 
 ;;; ;;;;;;;;;;;;;;;;
@@ -255,7 +272,16 @@
     (skipped . 0)
     (tests . 0)
     (name . #f)
-    (name-stack . ())))
+    (name-stack . ())
+    (rewriters . ,default-rewriters)
+    (never-print-dto . ,equal-alist-dto)
+    (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)))))
 
 (define default-test-info-dto equal-alist-dto)
 
@@ -387,13 +413,19 @@
         (lambda () cleanup-expr))))))
 
 (define (test-exit)
-  (write
-   `((tests passed: ,(test-ref 'passed))
-     (tests failed: ,(test-ref 'failed))
-     (tests skipped: ,(test-ref 'skipped))
-     (total number of tests: ,(test-ref 'tests))))
-  (newline)
+  (display "==== EXITING TEST SUITE =====\n")
+  (call-with-values (lambda () (inspect-test-info values))
+    display-report)
   (exit (if (zero? (test-ref/default 'failed 0))
             0
             1)))
 
+;;; Rewriters
+
+(define (test-rewrite obj)
+  (let loop ((rewriters (test-ref/default 'rewriters '())))
+    (cond
+      ((null? rewriters) obj)
+      (((caar rewriters) obj) ((cdar rewriters) obj))
+      (else (loop (cdr rewriters))))))
+
diff --git a/lib/conspire.sld b/lib/conspire.sld
index 8aff22a..73281b2 100644
--- a/lib/conspire.sld
+++ b/lib/conspire.sld
@@ -31,7 +31,7 @@
           test-update/default
           call-as-test call-as-group
           ;; Default test procedures
-          setup-name!
+          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
@@ -54,8 +54,11 @@
       (irritants conspire-error-irritants))
     (define (raise-conspire-error message . irritants)
       (raise (make-conspire-error message irritants))))
+  ;; Library information for test-info object
   (cond-expand
     (chicken (import (srfi 18))
-             (include "r7rs-srfi-18.scm"))
-    (else (include "r7rs-single-threaded.scm")))
+             (include "r7rs-srfi-18.scm")
+             (include-library-declarations "rewriters.chicken.scm"))
+    (else (include "r7rs-single-threaded.scm")
+          (include-library-declarations "rewriters.r7rs.scm")))
   (include "conspire.scm"))
\ No newline at end of file
diff --git a/lib/rewriters.chicken.scm b/lib/rewriters.chicken.scm
new file mode 100644
index 0000000..6b715f5
--- /dev/null
+++ b/lib/rewriters.chicken.scm
@@ -0,0 +1,48 @@
+#| Copyright © 2025 Peter McGoron
+ |
+ | Permission is hereby granted, free of charge, to any person obtaining
+ | a copy of this software and associated documentation files (the
+ | “Software”), to deal in the Software without restriction, including
+ | without limitation the rights to use, copy, modify, merge, publish,
+ | distribute, sublicense, and/or sell copies of the Software, and to
+ | permit persons to whom the Software is furnished to do so, subject to
+ | the following conditions:
+ |
+ | The above copyright notice and this permission notice shall be included
+ | in all copies or substantial portions of the Software.
+ |
+ | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND,
+ | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN
+ | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+ | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+ | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
+ | THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ |#
+
+(import (chicken memory representation)
+        (chicken condition))
+
+(begin
+  (define (default-on-pair pair)
+    (cons (test-rewrite (car pair))
+          (test-rewrite (cdr pair))))
+  (define (default-on-vector vec)
+    (vector-map test-rewrite vec))
+  (define (default-on-error error)
+    (cons 'error
+          (cons (error-object-message error)
+                (error-object-irritants error))))
+  (define (default-on-condition cond)
+    (map test-rewrite (condition->list cond)))
+  (define (default-on-record rec)
+    `(record (name ,(test-rewrite (record-instance-type rec)))
+             (elements
+              ,(vector-map test-rewrite (record->vector rec)))))
+  (define default-rewriters
+    `((,pair? . ,default-on-pair)
+      (,vector? . ,default-on-vector)
+      (,error-object? . ,default-on-error)
+      (,condition? . ,default-on-condition)
+      (,record-instance? . ,default-on-record))))
+
diff --git a/lib/rewriters.r7rs.scm b/lib/rewriters.r7rs.scm
new file mode 100644
index 0000000..8c3db78
--- /dev/null
+++ b/lib/rewriters.r7rs.scm
@@ -0,0 +1,26 @@
+#| Copyright © 2025 Peter McGoron
+ |
+ | Permission is hereby granted, free of charge, to any person obtaining
+ | a copy of this software and associated documentation files (the
+ | “Software”), to deal in the Software without restriction, including
+ | without limitation the rights to use, copy, modify, merge, publish,
+ | distribute, sublicense, and/or sell copies of the Software, and to
+ | permit persons to whom the Software is furnished to do so, subject to
+ | the following conditions:
+ |
+ | The above copyright notice and this permission notice shall be included
+ | in all copies or substantial portions of the Software.
+ |
+ | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND,
+ | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN
+ | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+ | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+ | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
+ | THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ |#
+
+(begin (define default-rewriters
+         `((,pair? . ,default-on-pair)
+           (,vector? . ,default-on-vector)
+           (,error-object? ,default-on-error))))
\ No newline at end of file