add conspire, with most meta-tests passed

1 files changed, 416 insertions, 0 deletions

diff --git a/tests/impl.scm b/tests/impl.scm
new file mode 100644
index 0000000..73e51b5
--- /dev/null
+++ b/tests/impl.scm
@@ -0,0 +1,416 @@
+#| 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.
+ |#
+
+;;; This is a meta-test suite for Conspire, similar to the meta-test
+;;; suite of SRFI-64.
+;;; 
+;;; This test suite is not as straightforward as a normal test suite,
+;;; since it tests the testing library itself. Hopefully, if the tests
+;;; pass, then the library works.
+
+(test-group "test-ref, test-contains? and test-ref/default"
+  (test-group "default keys"
+    (define (test-pair name key value)
+      (test-eq name key value))
+    (for-each (lambda (key value)
+                (let ((name (symbol->string key)))
+                  (with-test-assert (string-append "contains " name)
+                    (test-contains? key))
+                  (test-eq name value (test-ref key))))
+              '(setup-test after-test before-test report-test
+                           setup-group after-group before-group report-group
+                           on-exception)
+              (list 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)))
+  (let ((pair (cons #f #f)))
+    (test-eq "default pair" pair (test-ref/default 'nonexistent-key pair))))
+
+(test-group "test-set and test-set!"
+  (let ((pair (cons #f #f)))
+    (test-set! 'nonexistent-key pair)
+    (test-eq "set unused key" pair (test-ref 'nonexistent-key))
+    (parameterize ((test-info '(box)))
+      (test-eq "persistent across parameterization"
+               pair
+               (test-ref 'nonexistent-key))
+      (let ((pair2 (cons #f #f)))
+        (with-test-assert "made a new pair"
+          (not (eq? pair pair2)))
+        (test-set! 'nonexistent-key pair2)
+        (test-eq "set key to a new pair"
+                 pair2
+                 (test-ref 'nonexistent-key))))
+    (test-eq "outside of parameterization"
+             pair
+             (test-ref 'nonexistent-key)))
+  (parameterize ((test-info (list 'replace
+                                  (test-set 'other-key 123))))
+    (test-eqv "other key in parameterization"
+              123
+              (test-ref 'other-key)))
+  (test-eqv "does not affect outside"
+            456
+            (test-ref/default 'other-key 456))
+  (with-test-assert "deleted key"
+    (test-delete! 'nonexistent-key)
+    (not (test-contains? 'nonexistent-keys))))
+
+(test-group "call-with-name"
+  (with-test-assert "inherits test info"
+    (let ((success? #f))
+      (parameterize ((test-info (list 'replace (test-set 'inherits? #t))))
+        (call-with-name "test"
+          (lambda () (set! success? (test-ref 'inherits?)))))
+      success?))
+  (with-test-assert "called with new test name"
+    (call-with-name "test"
+      (lambda () (equal? (test-ref 'name) "test")))))
+
+;;; Now the actual test procedures need to be tested. This is done by
+;;; running everything in a dummy test-info that is overridden at each
+;;; test site with new procedures.
+;;; 
+;;; The dummy test info does not escape from exceptions, like the default
+;;; `on-exception` handler. Hence exceptions inside of a `call-as-test`
+;;; will trip the actual exception handler for the meta test-info.
+
+(define-values (dummy-dto dummy-dict)
+  (inspect-test-info
+   (lambda (dto dict)
+     (define dummy (lambda _ #t))
+     (values dto
+             (dict-set! dto
+                        dict
+                        'setup-test dummy
+                        'before-test dummy
+                        'after-test dummy
+                        'report-test dummy
+                        'setup-group dummy
+                        'after-group dummy
+                        'before-group dummy
+                        'report-group dummy
+                        'on-exception dummy)))))
+
+(test-group "call-as-test, dummy dict"
+  (test-group "before test"
+    (with-test-assert "before-test skips tests when returning #f"
+      (parameterize ((test-info
+                      (list 'replace
+                            (dict-set! dummy-dto dummy-dict
+                                       'before-test
+                                       (lambda (name) #f)))))
+        (let ((called? #f))
+          (call-as-test "name"
+                        (lambda () (set! called? #t)))
+          (not called?)))
+      (with-test-assert "before-test gets the test name"
+        (define inside-test-info
+          (dict-set! dummy-dto dummy-dict
+                     'before-test
+                     (lambda (name)
+                       (unless (equal? name "1234")
+                         (raise "exception"))
+                       #t)))
+        (parameterize ((test-info
+                        (list 'replace inside-test-info)))
+          (let ((called? #f))
+            (call-as-test "1234"
+                          (lambda () (set! called? #t)))
+            called?)))))
+  (test-group "after test"
+    (let ((called? #f)
+          (pair (cons #f #f)))
+      (define inside-test-info
+        (dict-set! dummy-dto dummy-dict
+                   'after-test
+                   (lambda (previous-dto previous-dict)
+                     (set! called?
+                           (dict-ref previous-dto previous-dict
+                                     'after-test-test)))))
+      (with-test-assert "after test is called with previous test-info"
+        (parameterize ((test-info
+                        (list 'replace dummy-dto inside-test-info)))
+          (call-as-test #f
+                        (lambda ()
+                          (test-set! 'after-test-test #t))))
+        called?))
+    (let* ((pair (cons #f #f))
+           (inside-test-info
+            (dict-set! dummy-dto dummy-dict
+                       'after-test
+                       (lambda _ pair))))
+      (test-eq "return value of call-as-test is after-test"
+               pair
+               (parameterize ((test-info
+                               (list 'replace
+                                     dummy-dto inside-test-info)))
+                 (call-as-test #f (lambda () #f))))))
+  (with-test-assert "setup-test runs in dynamic extent"
+    (let ((global-name "setup-test-name")
+          (called? #f)
+          (pair (cons #f #f)))
+      (define inside-test-info
+        (dict-set! dummy-dto dummy-dict
+                   'setup-test
+                   (lambda ()
+                     (test-set! 'setup-test-test pair))))
+      (parameterize ((test-info (list 'replace dummy-dto inside-test-info)))
+        (call-as-test global-name
+                      (lambda ()
+                        (set! called? (eq? (test-ref 'setup-test-test) pair)))))
+      (and called? (not (test-contains? 'setup-test-test)))))
+  (test-group "on-exception"
+    (with-test-assert "not called"
+      (call/cc
+       (lambda (return)
+         (define inside-test-info
+           (dict-set! dummy-dto dummy-dict
+                      'exception-not-called?
+                      #t
+                      'on-exception
+                      (lambda (exn return)
+                        (test-set! 'exception-not-called? #f))
+                      'after-test
+                      (lambda (previous-dto previous-dict)
+                        (return (dict-ref previous-dto previous-dict
+                                          'exception-not-called?)))))
+         (parameterize ((test-info (list 'replace dummy-dto
+                                         inside-test-info)))
+           (call-as-test #f (lambda () #f)))
+         #f)))
+    (let* ((message "exception message")
+           (caught #f)
+           (inside-test-info
+            (dict-set! dummy-dto dummy-dict
+                       'on-exception
+                       (lambda (exn return)
+                         (set! caught exn)
+                         (return)))))
+      (with-test-assert "called"
+        (parameterize ((test-info
+                        (list 'replace dummy-dto
+                              inside-test-info)))
+          (call-as-test #f (lambda ()
+                             (raise message)))
+          caught)))))
+
+;;; ;;;;;;;;;;;;;;;;
+;;; Testing the default test handler, except for 'report-test.
+;;; 
+;;; The default report test writes to standard output, and the
+;;; return value of report-test is the return value of call-as-test
+;;; because report-test is called by after-test.
+;;; 
+;;; For `silent-dict`, the report procedures return the dto and 
+;;; dictionary inside the test/group. This is different from the
+;;; dictionary containing the test/group, which is returned using
+;;; `(inspect-test-info values)` inside the dynamic extent.
+
+(define silent-dict
+  (dict-set! default-dto default-test-info-dict
+             'report-test values
+             'report-group values))
+
+(test-group "call-as-test, some defaults"
+  (test-group "tests that success is true"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (call-as-test #f (lambda () (test-set! 'success? #t)))
+        (inspect-test-info values)))
+    (test-eqv "passed number" 1 (dict-ref dto dict 'passed))
+    (test-eqv "failed number" 0 (dict-ref dto dict 'failed))
+    (test-eqv "test number" 1 (dict-ref dto dict 'tests)))
+  (test-group "test that success is false"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (call-as-test #f (lambda () (test-set! 'success? #f)))
+        (inspect-test-info values)))
+    (test-eqv "passed number" 0 (dict-ref dto dict 'passed))
+    (test-eqv "failed number" 1 (dict-ref dto dict 'failed))
+    (test-eqv "test number" 1 (dict-ref dto dict 'tests)))
+  (test-group "success not set"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (call-as-test #f (lambda () #f))
+        (inspect-test-info values)))
+    (test-eqv "passed number" 0 (dict-ref dto dict 'passed))
+    (test-eqv "failed number" 1 (dict-ref dto dict 'failed))
+    (test-eqv "test number" 1 (dict-ref dto dict 'tests)))
+  (test-group "catching exceptions"
+    (define pair (cons #f #f))
+    (define-values (inner-dto inner-dict outer-dto outer-dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (let*-values (((inner-dto inner-dict) (call-as-test #f (lambda () (raise pair))))
+                      ((outer-dto outer-dict) (inspect-test-info values)))
+          (values inner-dto inner-dict outer-dto outer-dict))))
+    (test-eqv "exception" pair (dict-ref inner-dto inner-dict 'exception))
+    (test-eqv "passed number" 0 (dict-ref outer-dto outer-dict 'passed))
+    (test-eqv "failed number" 1 (dict-ref outer-dto outer-dict 'failed))
+    (test-eqv "test number" 1 (dict-ref outer-dto outer-dict 'tests))))
+
+(test-group "call-as-group"
+  (with-test-assert "group with no tests"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (call-as-group #f (lambda () #f))
+        (inspect-test-info values)))
+    (test-eqv "passed number" 0 (dict-ref dto dict 'passed))
+    (test-eqv "tests number" 0 (dict-ref dto dict 'tests))
+    (test-eqv "failed number" 0 (dict-ref dto dict 'failed))
+    (test-eqv "skipped number" 0 (dict-ref dto dict 'skipped)))
+  (with-test-assert "group with 1 test"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-group #f (with-test-assert #f #t))
+        (inspect-test-info values)))
+    (test-eqv "passed number" 1 (dict-ref dto dict 'passed))
+    (test-eqv "tests number" 1 (dict-ref dto dict 'tests))
+    (test-eqv "failed number" 0 (dict-ref dto dict 'failed))
+    (test-eqv "skipped number" 0 (dict-ref dto dict 'skipped)))
+  (test-group "group with multiple test"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-group #f
+          (call-as-test #f (lambda ()
+                            (test-set! 'success? #t)))
+          (call-as-test #f (lambda ()
+                            (test-set! 'success? #t)))
+          (call-as-test #f (lambda ()
+                            (test-set! 'success? #f)))
+          (test-skip-all
+           (call-as-test #f (lambda ()
+                             (test-set! 'success? #f)))))
+        (inspect-test-info values)))
+    (test-eqv "passed number" 2 (dict-ref dto dict 'passed))
+    (test-eqv "tests number" 4 (dict-ref dto dict 'tests))
+    (test-eqv "failed number" 1 (dict-ref dto dict 'failed))
+    (test-eqv "skipped number" 1 (dict-ref dto dict 'skipped)))
+  (with-test-assert "nested groups"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-group #f
+          (with-test-assert #f #t)
+          (test-group #f (with-test-assert #f #f)))
+        (inspect-test-info values)))
+    (test-eqv "passed number" 1 (dict-ref dto dict 'passed))
+    (test-eqv "tests number" 2 (dict-ref dto dict 'tests))
+    (test-eqv "failed number" 1 (dict-ref dto dict 'failed))
+    (test-eqv "skipped number" 0 (dict-ref dto dict 'skipped))))
+
+(test-group "test application"
+  (with-test-assert "true"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-application "not" (not not) (arg #f))
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'passed)))
+  (with-test-assert "false"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-application "not" (not not) (arg #t))
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'failed))))
+
+(test-group "test-equal"
+  (with-test-assert "true"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-equal "equal" "abc" "abc")
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'passed)))
+  (with-test-assert "false"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-equal "equal" "abc" "def")
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'failed))))
+
+(test-group "test-eq"
+  (with-test-assert "true"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-eq "eq" 'abc 'abc)
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'passed)))
+  (with-test-assert "false"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-eq "eq" 'abc 'def)
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'failed))))
+
+(test-group "test-eqv"
+  (with-test-assert "true"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-eqv "eqv" 100 100)
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'passed)))
+  (with-test-assert "false"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-eqv "eqv" 100 200)
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'failed))))
+
+(test-group "test-approximate"
+  (with-test-assert "true"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-approximate "approx" 1 1.001 0.01)
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'passed)))
+  (with-test-assert "false"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (test-approximate "approx" 100 1.01 0.01)
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'failed))))
+
+(test-group "test-error"
+  (with-test-assert "thrown exception"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (with-test-error #f
+          (lambda (ex) (equal? ex "exception"))
+          (raise "exception"))
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'passed)))
+  (with-test-assert "no thrown exception"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (with-test-error #f
+          (lambda (ex) #t)
+          #f)
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'failed)))
+  (with-test-assert "incorrectly thrown exception"
+    (define-values (dto dict)
+      (parameterize ((test-info (list 'replace default-dto silent-dict)))
+        (with-test-error #f number? (raise "exception"))
+        (inspect-test-info values)))
+    (eqv? 1 (dict-ref dto dict 'failed))))
+
+(test-exit)