init

5 files changed, 188 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0880f22
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,6 @@
+*.build.sh
+*.install.sh
+*.import.scm
+*.so
+*.link
+*.o
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..aa34c53
--- /dev/null
+++ b/README.md
@@ -0,0 +1,12 @@
+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.
+
+To use, just import `(mcgoron srfi 64)` and use `(factory)` to make a new
+test runner.
+
+There is currently no test suite for this because it would be tedious to
+write.
diff --git a/mcgoron-srfi-64.egg b/mcgoron-srfi-64.egg
new file mode 100644
index 0000000..aecbeef
--- /dev/null
+++ b/mcgoron-srfi-64.egg
@@ -0,0 +1,11 @@
+((author "Peter McGoron")
+ (version "0.1.0")
+ (synopsis "A test runner for SRFI 64 that outputs SEXPRs")
+ (category "test")
+ (license "Apache-2.0")
+ (dependencies "r7rs" "srfi-64")
+ (test-dependencies "test")
+ (components (extension mcgoron.srfi.64
+               (source "mcgoron.srfi.64.sld")
+               (source-dependencies "mcgoron.srfi.64.scm")
+               (csc-options "-R" "r7rs" "-X" "r7rs"))))
diff --git a/mcgoron.srfi.64.scm b/mcgoron.srfi.64.scm
new file mode 100644
index 0000000..a69c4c8
--- /dev/null
+++ b/mcgoron.srfi.64.scm
@@ -0,0 +1,136 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define *global-make-displayable*
+  (list
+   (cons pair?
+         (lambda (value)
+           (cons (make-displayable (car value))
+                 (make-displayable (cdr value)))))
+   (cons vector?
+         (lambda (value)
+           (vector-map make-displayable value)))
+   (cons eof-object?
+         (lambda (_)
+           `(an-eof-object)))))
+
+(cond-expand
+ (chicken
+  (set! *global-make-displayable*
+        (cons
+         (cons condition?
+               (lambda (value)
+                 (make-displayable (condition->list value))))
+         *global-make-displayable*)))
+ (else))
+
+(define (make-displayable runner value)
+  (let loop ((lst (get-displayables (test-runner-aux-value runner))))
+    (if (null? lst)
+        value
+        (let* ((pair (car lst))
+               (predicate? (car pair))
+               (transformer (cdr pair)))
+          (if (predicate? value)
+              (transformer value)
+              (loop (cdr lst)))))))
+
+(define-record-type <aux>
+  (aux tests-passed-in-group tests-failed-in-group tests-skipped-in-group
+       displayables)
+  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!)
+  (displayables get-displayables set-displayables!))
+
+(define (on-test-begin runner)
+  (let ((kind (test-result-kind runner)))
+    (cond
+      ((eq? kind 'skip)
+       (set-tests-skipped-in-group! runner
+                                    (+ 1
+                                       (get-tests-skipped-in-group
+                                        runner))))
+      ((test-passed? runner)
+       (set-tests-passed-in-group! runner
+                                   (+ 1
+                                      (get-tests-passed-in-group
+                                       runner))))
+      (else
+       (set-tests-failed-in-group! runner
+                                   (+ 1
+                                      (get-tests-failed-in-group
+                                       runner)))))
+    (write `(test ,(test-runner-test-name runner)
+                  (result ,kind)
+                  (properties ,@(test-result-alist runner))))
+    (newline)))
+
+(define (on-group-begin runner suite-name count)
+  (write `(start ,suite-name))
+  (newline))
+
+(define (on-group-end runner)
+  (let ((passed (get-tests-passed-in-group runner))
+        (failed (get-tests-failed-in-group runner))
+        (skipped (get-tests-skipped-in-group runner)))
+    (write `(end (passed ,passed)
+                 (failed ,failed)
+                 (skipped ,skipped)
+                 (tests ,(+ passed failed skipped))))
+    (newline))
+  (set-tests-passed-in-group! runner 0)
+  (set-tests-failed-in-group! runner 0)
+  (set-tests-skipped-in-group! runner 0))
+
+(define (on-bad-count runner actual expected)
+  (write `(warning expected ,expected
+                   got ,actual))
+  (newline))
+
+(define (on-bad-end-name runner begin-name end-name)
+  (error "mismatch in test names" begin-name end-name
+         (test-runner-group-stack runner)
+         runner))
+
+(define (on-final runner)
+  (write `(summary
+           (pass (expected ,(test-runner-pass-count runner))
+                 (not-expected ,(test-runner-pass-count runner)))
+           (fail (expected ,(test-runner-fail-count runner))
+                 (not-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))))
+
+(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)
+    (test-runner-on-group-begin! runner on-group-begin)
+    (test-runner-on-group-end! runner on-group-end)
+    (test-runner-on-bad-count! runner on-bad-end-name)
+    (test-runner-on-final! runner on-final)))
\ No newline at end of file
diff --git a/mcgoron.srfi.64.sld b/mcgoron.srfi.64.sld
new file mode 100644
index 0000000..5bafb37
--- /dev/null
+++ b/mcgoron.srfi.64.sld
@@ -0,0 +1,23 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (mcgoron srfi 64)
+  (import (scheme base) (scheme write) (srfi 64))
+  (cond-expand
+   (chicken (import (chicken condition)))
+   (else))
+  (export factory add-displayable!)
+  (include "mcgoron.srfi.64.scm"))