path: root/tests/impl.scm

#| 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"
    (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
                            skip-test? when-test-skipped
                            setup-group! after-group before-group!
                            report-group on-exception)
              (list default-setup-test! default-after-test
                    default-before-test! default-report-test
                    default-skip-test? default-when-test-skipped
                    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))))

;;; 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 _ #f))
     (values dto
             (dict-set! dto
                        dict
                        'skip-test? dummy
                        'before-test! dummy
                        'setup-test! dummy
                        'when-test-skipped dummy
                        'after-test values
                        'report-test dummy
                        'on-exception dummy
                        'setup-group! dummy
                        'before-group! dummy
                        'after-group values
                        'report-group dummy)))))

(test-group "call-as-test, dummy dict"
  (test-group "before test"
    (with-test-assert "skip-test? skips tests when returning #f"
      (parameterize ((test-info
                      (list 'replace
                            (dict-set! dummy-dto dummy-dict
                                       'skip-test?
                                       (lambda (name) #t)))))
        (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 (name)
                     (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-test-info-dto default-test-info-dict
             'before-test! values
             'before-group! values
             'report-test values
             'report-group values))

(test-group "call-as-test, some defaults"
  (test-group "no name"
    (define-values (dto dict outer-dto outer-dict)
      (parameterize ((test-info (list 'replace default-test-info-dto silent-dict)))
        (let*-values (((inner-dto inner-dict)
                       (call-as-test #f (lambda () #f)))
                      ((outer-dto outer-dict)
                       (inspect-test-info values)))
          (values inner-dto inner-dict outer-dto outer-dict))))
    (test-eqv "name is #f" #f (dict-ref dto dict 'name))
    (test-eqv "name-stack" '() (dict-ref dto dict 'name-stack))
    (test-eqv "outer name is #f" #f (dict-ref outer-dto outer-dict 'name))
    (test-eqv "outer name-stack" '() (dict-ref outer-dto outer-dict 'name-stack)))
  (test-group "named"
    (define-values (dto dict outer-dto outer-dict)
      (parameterize ((test-info (list 'replace default-test-info-dto silent-dict)))
        (let*-values (((inner-dto inner-dict)
                       (call-as-test "asdfasdf" (lambda () #f)))
                      ((outer-dto outer-dict)
                       (inspect-test-info values)))
          (values inner-dto inner-dict outer-dto outer-dict))))
    (test-equal "name is #f" "asdfasdf" (dict-ref dto dict 'name))
    (test-equal "name-stack" '("asdfasdf") (dict-ref dto dict 'name-stack))
    (test-eqv "outer name is #f" #f (dict-ref outer-dto outer-dict 'name))
    (test-eqv "outer name-stack" '() (dict-ref outer-dto outer-dict 'name-stack)))
  (test-group "tests that success is true"
    (define-values (dto dict)
      (parameterize ((test-info (list 'replace default-test-info-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-test-info-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-test-info-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-test-info-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"
  (test-group "group with no tests"
    (define-values (dto dict)
      (parameterize ((test-info (list 'replace default-test-info-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)))
  (test-group "group with 1 test"
    (define-values (dto dict)
      (parameterize ((test-info (list 'replace default-test-info-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 tests"
    (define-values (dto dict)
      (parameterize ((test-info (list 'replace default-test-info-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)))
    (begin
      (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))))
  (test-group "nested groups"
    (define inner-dict #f)
    (define inner-dto #f)
    (define-values (dto dict)
      (parameterize ((test-info (list 'replace default-test-info-dto silent-dict)))
        (test-group "gr1"
          (with-test-assert #f #t)
          (test-group "gr2"
            (with-test-assert #f
              (inspect-test-info
               (lambda (dto dict)
                 (set! inner-dto dto)
                 (set! inner-dict dict)))
              #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-eqv "inner name" #f (dict-ref inner-dto inner-dict 'name))
    (test-equal "inner name stack" '("gr2" "gr1")
                (dict-ref inner-dto inner-dict 'name-stack))))

(test-group "test application"
  (with-test-assert "true"
    (define-values (dto dict)
      (parameterize ((test-info (list 'replace default-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-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-test-info-dto silent-dict)))
        (with-test-error #f number? (raise "exception"))
        (inspect-test-info values)))
    (eqv? 1 (dict-ref dto dict 'failed))))

(test-exit)