add conspire, with most meta-tests passed

4 files changed, 491 insertions, 0 deletions

diff --git a/lib/conspire.scm b/lib/conspire.scm
new file mode 100644
index 0000000..bc0ad5b
--- /dev/null
+++ b/lib/conspire.scm
@@ -0,0 +1,377 @@
+#| 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.
+ |#
+
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; Manipulating the test info
+;;; ;;;;;;;;;;;;;;;;;;;
+
+(define (modify-test-info! proc)
+  (let ((mutex (test-info-mutex (test-info))))
+    (dynamic-wind
+     (lambda () (mutex-lock! mutex))
+     (lambda ()
+       (set-test-info-dict! (test-info)
+                            (proc (test-info-dto (test-info))
+                                  (test-info-dict (test-info)))))
+     (lambda () (mutex-unlock! mutex)))))
+
+(define (inspect-test-info proc)
+  (let ((mutex (test-info-mutex (test-info))))
+    (dynamic-wind
+     (lambda () (mutex-lock! mutex))
+     (lambda () (proc (test-info-dto (test-info))
+                      (test-info-dict (test-info))))
+     (lambda () (mutex-unlock! mutex)))))
+
+(define-syntax define-destructive-test-info-procedure
+  (syntax-rules ()
+    ((_ (name args ...) proc)
+     (define (name args ...)
+       (modify-test-info! (lambda (dto dictionary)
+                            (proc dto dictionary args ...)))))
+    ((_ (name . args) proc)
+     (define (name . other-args)
+       (modify-test-info! (lambda (dto dictionary)
+                            (apply proc dto dictionary other-args)))))))
+
+(define-syntax define-inspecting-test-info-procedure
+  (syntax-rules ()
+    ((_ (name args ...) proc)
+     (define (name args ...)
+       (inspect-test-info (lambda (dto dictionary)
+                            (proc dto dictionary args ...)))))
+    ((_ (name . args) proc)
+     (define (name . other-args)
+       (inspect-test-info (lambda (dto dictionary)
+                            (apply proc dto dictionary other-args)))))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Mutating operations on the test info
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-destructive-test-info-procedure
+    (test-set! . args) dict-set!)
+(define-destructive-test-info-procedure
+    (test-update! key updater . rest) dict-update!)
+(define-destructive-test-info-procedure
+    (test-update/default! key updater default) dict-update/default!)
+(define-destructive-test-info-procedure
+    (test-delete! . keys) dict-delete!)
+
+(define-inspecting-test-info-procedure
+    (test-contains? key) dict-contains?)
+(define-inspecting-test-info-procedure
+    (test-ref key . rest) dict-ref)
+(define-inspecting-test-info-procedure
+    (test-ref/default key default) dict-ref/default)
+(define-inspecting-test-info-procedure
+    (test-set . args) dict-set!)
+(define-inspecting-test-info-procedure
+    (test-update/default key value) dict-update/default!)
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Manipulating the parameter object
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (call-with-name name thunk)
+  (define dict
+    (inspect-test-info
+     (lambda (dto dict)
+       (set! dict (dict-set! dto dict 'name name))
+       (if name
+           (dict-update/default! dto dict
+                                 'name-stack
+                                 (lambda (pair) (cons name pair))
+                                 '())
+           dict))))
+  (parameterize ((test-info (list 'replace dict)))
+    (thunk)))
+
+(define (call-as-test name thunk)
+  (when ((test-ref 'before-test) name)
+    (let ((thunk
+           (lambda ()
+             (call/cc
+              (lambda (return)
+                (define handle
+                  (let ((on-exception (test-ref 'on-exception))
+                        (return (lambda () (return #f))))
+                    (lambda (exn) (on-exception exn return))))
+                ((test-ref 'setup-test))
+                (with-exception-handler handle thunk)))
+             (inspect-test-info values))))
+      (call-with-values (lambda () (call-with-name name thunk))
+        (test-ref 'after-test)))))
+
+;;; ;;;;;;;;;;
+;;; Default handlers
+;;; ;;;;;;;;;;
+
+(define (default-setup-test)
+  (test-delete! 'success?))
+
+(define (default-after-test previous-dto previous-test-info)
+  (test-update/default! 'tests
+                        (lambda (x) (+ x 1))
+                        0)
+  (let ((success? (dict-ref/default previous-dto
+                                    previous-test-info
+                                    'success?
+                                    #f)))
+    (test-update/default! (if success? 'passed 'failed)
+                          (lambda (x) (+ 1 x))
+                          0)
+    ((test-ref 'report-test) previous-dto previous-test-info)))
+
+(define (default-report-test previous-dto previous-test-info)
+  (let ((verbose? (test-ref/default 'verbose? #f))
+        (specifically-verbose? (dict-ref/default previous-dto
+                                                 previous-test-info
+                                                 'verbose?
+                                                 #f))
+        (success? (dict-ref/default previous-dto
+                                    previous-test-info
+                                    'success?
+                                    #f))
+        (name (cond
+                ((dict-ref previous-dto previous-test-info 'name))
+                (else ""))))
+    (cond
+      (success?
+       (when (or verbose? specifically-verbose?)
+         (display (string-append "success:           \"" name "\"\n"))))
+      (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))))
+    (values previous-dto previous-test-info)))
+
+(define (default-before-test name)
+  #t)
+
+(define (default-before-group name)
+  (if name
+      (display (string-append "entering group \"" name "\"\n"))
+      (display "entering group\n"))
+  #t)
+
+(define (default-setup-group name)
+  (test-set! 'tests 0)
+  (test-set! 'passed 0)
+  (test-set! 'failed 0)
+  (test-set! 'skipped 0))
+
+(define (default-after-group previous-dto previous-info)
+  (define (update/previous! name)
+    (test-update/default!
+     name
+     (lambda (x) (+ x (dict-ref/default previous-dto
+                                        previous-info
+                                        name
+                                        0)))
+     0))
+  (update/previous! 'tests)
+  (update/previous! 'passed)
+  (update/previous! 'failed)
+  (update/previous! 'skipped)
+  ((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 "group \"" name "\" exited.\n"))))
+    (else (display "group exited.\n")))
+  (values previous-dto previous-info))
+
+(define (default-on-exception exn return)
+  (test-set! 'success? #f)
+  (test-set! 'exception exn)
+  (return))
+
+;;; ;;;;;;;;;;;;;;;;
+;;; test info
+;;; ;;;;;;;;;;;;;;;;
+
+(define default-test-info-dict
+  `((before-test . ,default-before-test)
+    (setup-test . ,default-setup-test)
+    (after-test . ,default-after-test)
+    (report-test . ,default-report-test)
+    (setup-group . ,default-setup-group)
+    (after-group . ,default-after-group)
+    (before-group . ,default-before-group)
+    (report-group . ,default-report-group)
+    (on-exception . ,default-on-exception)
+    (passed . 0)
+    (failed . 0)
+    (skipped . 0)
+    (tests . 0)))
+
+(define default-dto equal-alist-dto)
+
+(define test-info
+  (make-parameter
+   (list 'replace default-dto default-test-info-dict)
+   (lambda (value)
+     (cond
+       ((not (pair? value))
+        (raise-conspire-error "invalid arguments to parameterize"
+                              value))
+       ((eq? (car value) 'box)
+        (unless (null? (cdr value))
+          (raise-conspire-error "invalid arguments to copy"
+                                value))
+        (inspect-test-info make-test-info))
+       ((eq? (car value) 'replace)
+        (cond
+          ((null? (list-tail value 1))
+           (raise-conspire-error "not enough arguments to replace"
+                                 value))
+          ((null? (list-tail value 2))
+           (inspect-test-info (lambda (dto _)
+                                (make-test-info dto
+                                                (list-ref value 1)))))
+          ((null? (list-tail value 3))
+           (make-test-info (list-ref value 1) (list-ref value 2)))
+          (else (raise-conspire-error "too many arguments to replace"
+                                      value))))
+       ((eq? (car value) 'operate)
+        (call-with-values (lambda ()
+                            (inspect-test-info (list-ref value 1)))
+          make-test-info))
+       (else (raise-conspire-error "unknown command" value))))))
+
+;;; ;;;;;;;;;;;;
+;;; Wrappers and semi-compatability with SRFI-64
+;;; ;;;;;;;;;;;;
+
+(define-syntax test-application
+  (syntax-rules ()
+    ((test-application test-name (name expr) ...)
+     (call-as-test test-name (lambda ()
+                               (test-set! (quote name) (quote expr)) ...
+                               (let ((name expr) ...)
+                                 (test-set! 'application (list name ...))
+                                 (test-set! 'success? (name ...))))))))
+
+(define-syntax with-test-assert
+  (syntax-rules ()
+    ((_ name body ...)
+     (call-as-test name (lambda ()
+                          (test-set! 'success?
+                                     (let () body ...)))))))
+
+(define-syntax test-equal
+  (syntax-rules ()
+    ((_ name %expected %actual)
+     (test-application name
+                       (procedure equal?)
+                       (expected %expected)
+                       (actual %actual)))))
+
+(define-syntax test-eqv
+  (syntax-rules ()
+    ((_ name %expected %actual)
+     (test-application name
+                       (procedure eqv?)
+                       (expected %expected)
+                       (actual %actual)))))
+
+
+(define-syntax test-eq
+  (syntax-rules ()
+    ((_ name %expected %actual)
+     (test-application name
+                       (procedure eq?)
+                       (expected %expected)
+                       (actual %actual)))))
+
+(define (%test-approximate expected actual error)
+  (<= (abs (- expected actual)) error))
+
+(define-syntax test-approximate
+  (syntax-rules ()
+    ((_ name %expected %actual %error)
+     (test-application name
+                       (procedure %test-approximate)
+                       (expected %expected)
+                       (actual %actual)
+                       (error %error)))))
+
+(define (call-as-test-error name error-predicate thunk)
+  (define (outer-thunk)
+    (test-set! 'success?
+               (call/cc
+                (lambda (return)
+                  (with-exception-handler (lambda (ex)
+                                            (test-set! 'exception ex)
+                                            (return (error-predicate ex)))
+                    (lambda () (thunk) #f))))))
+  (call-as-test name outer-thunk))
+
+(define-syntax with-test-error
+  (syntax-rules ()
+    ((_ name error-predicate body ...)
+     (call-as-test-error name error-predicate
+                         (lambda () body ...)))))
+
+(define (call-as-group name thunk)
+  (when ((test-ref 'before-group) name)
+    (let ((inside (lambda ()
+                    ((test-ref 'setup-group) name)
+                    (thunk)
+                    (inspect-test-info values))))
+      (call-with-values (lambda () (call-with-name name inside))
+        (test-ref 'after-group)))))
+
+(define-syntax test-skip-all
+  (syntax-rules ()
+    ((_ body ...)
+     (parameterize ((test-info
+                     (list 'replace
+                           (test-set 'before-test
+                                     (lambda (_) #f)))))
+       body ...))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ name body ...)
+     (call-as-group name (lambda () body ...)))))
+
+(define-syntax with-test-group-cleanup
+  (syntax-rules ()
+    ((_ name body ... cleanup-expr)
+     (test-group name
+       (dynamic-wind
+        (lambda () #f)
+        (lambda () body ...)
+        (lambda () cleanup-expr))))))
+
+(define (test-exit)
+  (exit (if (zero? (test-ref/default 'failed 0))
+            0
+            1)))
+
diff --git a/lib/conspire.sld b/lib/conspire.sld
new file mode 100644
index 0000000..241ad1e
--- /dev/null
+++ b/lib/conspire.sld
@@ -0,0 +1,56 @@
+#| 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.
+ |#
+
+(define-library (conspire)
+  (import (scheme base) (scheme write) (scheme process-context) (srfi 225))
+  (export test-set! test-update! test-update/default!
+          test-contains?
+          test-ref test-ref/default
+          test-set test-update/default
+          test-delete!
+          test-info
+          call-with-name call-as-test
+          default-setup-test default-after-test default-before-test
+          default-report-test default-setup-group default-after-group
+          default-before-group default-report-group default-on-exception
+          default-test-info-dict default-dto
+          modify-test-info! inspect-test-info
+          test-application with-test-assert
+          test-equal test-eqv test-eq test-approximate
+          call-as-test-error with-test-error
+          call-as-group test-group
+          with-test-group-cleanup
+          test-skip-all
+          test-exit)
+  (begin
+    (define-record-type <conspire-error>
+      (make-conspire-error message irritants)
+      conspire-error?
+      (message conspire-error-message)
+      (irritants conspire-error-irritants))
+    (define (raise-conspire-error message . irritants)
+      (raise (make-conspire-error message irritants))))
+  (cond-expand
+    (chicken (import (srfi 18))
+             (include "r7rs-srfi-18.scm"))
+    (else (include "r7rs-single-threaded.scm")))
+  (include "conspire.scm"))
\ No newline at end of file
diff --git a/lib/r7rs-single-threaded.scm b/lib/r7rs-single-threaded.scm
new file mode 100644
index 0000000..fe57187
--- /dev/null
+++ b/lib/r7rs-single-threaded.scm
@@ -0,0 +1,27 @@
+#| 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.
+ |#
+
+(define-record-type <test-info>
+  (make-test-info dto dict)
+  test-info?
+  (dto test-info-dto)
+  (dict test-info-dict set-test-info-dict!))
\ No newline at end of file
diff --git a/lib/r7rs-srfi-18.scm b/lib/r7rs-srfi-18.scm
new file mode 100644
index 0000000..59634d8
--- /dev/null
+++ b/lib/r7rs-srfi-18.scm
@@ -0,0 +1,31 @@
+#| 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.
+ |#
+
+(define-record-type <test-info>
+  (%make-test-info dto dict mutex)
+  test-info?
+  (dto test-info-dto)
+  (dict test-info-dict set-test-info-dict!)
+  (mutex test-info-mutex))
+
+(define (make-test-info dto dict)
+  (%make-test-info dto dict (make-mutex "test-info")))
\ No newline at end of file