path: root/tests/impl.scm

;;; 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)))
                  (test-body (string-append "contains " name)
                    (test-contains? key))
                  (test-eq name value (test-ref key))))
              '(skip-test? when-test-skipped before-test! setup-test!
                           cleanup-test! after-test report-test
                           on-exception-in-test
                           skip-group? when-group-skipped before-group!
                           setup-group! cleanup-group! after-group
                           report-group on-exception-in-group)
              (list default-skip-test? default-when-test-skipped
                    default-before-test! default-setup-test! default-cleanup-test!
                    default-after-test default-report-test
                    default-on-exception-in-test
                    default-skip-group? default-when-group-skipped
                    default-before-group! default-setup-group! default-cleanup-group!
                    default-after-group default-report-group
                    default-on-exception-in-group)))
  (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 (test-info-dict)))
      (test-eq "persistent across parameterization"
               pair
               (test-ref 'nonexistent-key))
      (let ((pair2 (cons #f #f)))
        (test-body "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 (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))
  (test-body "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 dummy-dict
  (let ((dummy (lambda _ #f)))
    (dict-set! (test-dto)
               default-test-info-dict
               'skip-test? dummy
               'when-test-skipped dummy
               'before-test! dummy
               'setup-test! dummy
               'cleanup-test! dummy
               'after-test values
               'report-test dummy
               'on-exception-in-test dummy
               'skip-group? dummy
               'when-group-skipped dummy
               'before-group! dummy
               'setup-group! dummy
               'cleanup-group! dummy
               'after-group values
               'report-group dummy
               'on-exception-in-group dummy)))

(test-group "call-as-test, dummy dict"
  (test-group "before test"
    (test-body "skip-test? skips tests when returning #f"
      (parameterize ((test-info
                      (dict-set! (test-dto)
                                 dummy-dict
                                 'skip-test?
                                 (lambda (name) #t))))
        (let ((called? #f))
          (call-as-test "name" (lambda () (set! called? #t)))
          (not called?))))
    (test-body "before-test gets the test name"
      (parameterize ((test-info
                      (dict-set! (test-dto)
                                 dummy-dict
                                 'before-test!
                                 (lambda (name)
                                   (unless (equal? name "1234")
                                     (raise "exception"))
                                   #t))))
        (let ((called? #f))
          (call-as-test "1234"
                        (lambda () (set! called? #t)))
          called?))))
  (test-group "after test"
    (let ((called? #f)
          (pair (cons #f #f)))
      (test-body "after test is called with previous test-info"
        (parameterize ((test-info
                        (dict-set! (test-dto) dummy-dict
                                   'after-test
                                   (lambda (previous-dict)
                                     (set! called?
                                           (dict-ref (test-dto)
                                                     previous-dict
                                                     'after-test-test))))))
          (call-as-test #f
                        (lambda ()
                          (test-set! 'after-test-test #t))))
        called?))
    (let* ((pair (cons #f #f)))
      (test-eq "return value of call-as-test is after-test"
               pair
               (parameterize ((test-info
                               (dict-set! (test-dto) dummy-dict
                                          'after-test
                                          (lambda _ pair))))
                 (call-as-test #f (lambda () #f))))))
  (test-body "setup-test runs in dynamic extent"
    (let ((global-name "setup-test-name")
          (called? #f)
          (pair (cons #f #f)))
      (parameterize ((test-info
                      (dict-set! (test-dto)
                                 dummy-dict
                                 'setup-test!
                                 (lambda (name)
                                   (test-set! 'setup-test-test pair)))))
        (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"
    (test-body "not called"
      (call/cc
       (lambda (return)
         (define inside-test-info
           (dict-set! (test-dto)
                      dummy-dict
                      'exception-not-called?
                      #t
                      'on-exception-in-test
                      (lambda (exn return)
                        (test-set! 'exception-not-called? #f)
                        (return))
                      'after-test
                      (lambda (previous-dict)
                        (return (dict-ref (test-dto)
                                          previous-dict
                                          'exception-not-called?)))))
         (parameterize ((test-info inside-test-info))
           (call-as-test #f (lambda () #f)))
         #f)))
    (let* ((message "exception message")
           (caught #f))
      (test-body "called"
        (parameterize ((test-info (dict-set! (test-dto) dummy-dict
                                             'on-exception-in-test
                                             (lambda (exn return)
                                               (set! caught exn)
                                               (return)))))
          (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-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 (dict outer-dict)
      (parameterize ((test-info silent-dict))
        (let ((inner-dict (call-as-test #f (lambda () #f))))
          (values inner-dict (test-info-dict)))))
    (test-eqv "name is #f" #f (dict-ref (test-dto) dict 'name))
    (test-eqv "name-stack" '() (dict-ref (test-dto) dict 'name-stack))
    (test-eqv "outer name is #f" #f (dict-ref (test-dto) outer-dict 'name))
    (test-eqv "outer name-stack" '() (dict-ref (test-dto) outer-dict 'name-stack)))
  (test-group "named"
    (define-values (dict outer-dict)
      (parameterize ((test-info silent-dict))
        (let ((inner-dict (call-as-test "asdfasdf" (lambda () #f))))
          (values inner-dict (test-info-dict)))))
    (test-equal "name is #f" "asdfasdf" (dict-ref (test-dto) dict 'name))
    (test-equal "name-stack" '("asdfasdf") (dict-ref (test-dto) dict 'name-stack))
    (test-eqv "outer name is #f" #f (dict-ref (test-dto) outer-dict 'name))
    (test-eqv "outer name-stack" '() (dict-ref (test-dto) outer-dict 'name-stack)))
  (test-group "tests that success is true"
    (define dict
      (parameterize ((test-info silent-dict))
        (call-as-test #f (lambda () (test-set! 'success? #t)))
        (test-info-dict)))
    (test-eqv "passed number" 1 (dict-ref (test-dto) dict 'passed))
    (test-eqv "failed number" 0 (dict-ref (test-dto) dict 'failed))
    (test-eqv "test number" 1 (dict-ref (test-dto) dict 'tests)))
  (test-group "test that success is false"
    (define dict
      (parameterize ((test-info silent-dict))
        (call-as-test #f (lambda () (test-set! 'success? #f)))
        (test-info-dict)))
    (test-eqv "passed number" 0 (dict-ref (test-dto) dict 'passed))
    (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed))
    (test-eqv "test number" 1 (dict-ref (test-dto) dict 'tests)))
  (test-group "success not set"
    (define dict
      (parameterize ((test-info silent-dict))
        (call-as-test #f (lambda () #f))
        (test-info-dict)))
    (test-eqv "passed number" 0 (dict-ref (test-dto) dict 'passed))
    (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed))
    (test-eqv "test number" 1 (dict-ref (test-dto) dict 'tests)))
  (test-group "catching exceptions"
    (define pair (cons #f #f))
    (define-values (inner-dict outer-dict)
      (parameterize ((test-info silent-dict))
        (let ((inner-dict (call-as-test #f (lambda () (raise pair)))))
          (values inner-dict (test-info-dict)))))
    (test-eqv "exception" pair (dict-ref (test-dto) inner-dict 'exception))
    (test-eqv "passed number" 0 (dict-ref (test-dto) outer-dict 'passed))
    (test-eqv "failed number" 1 (dict-ref (test-dto) outer-dict 'failed))
    (test-eqv "test number" 1 (dict-ref (test-dto) outer-dict 'tests))))

(test-group "call-as-group"
  (test-group "group with no tests"
    (define dict
      (parameterize ((test-info silent-dict))
        (call-as-group #f (lambda () #f))
        (test-info-dict)))
    (test-eqv "passed number" 0 (dict-ref (test-dto) dict 'passed))
    (test-eqv "tests number" 0 (dict-ref (test-dto) dict 'tests))
    (test-eqv "failed number" 0 (dict-ref (test-dto) dict 'failed))
    (test-eqv "skipped number" 0 (dict-ref (test-dto) dict 'skipped)))
  (test-group "group with 1 test"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-group #f (test-body #f #t))
        (test-info-dict)))
    (test-eqv "passed number" 1 (dict-ref (test-dto) dict 'passed))
    (test-eqv "tests number" 1 (dict-ref (test-dto) dict 'tests))
    (test-eqv "failed number" 0 (dict-ref (test-dto) dict 'failed))
    (test-eqv "skipped number" 0 (dict-ref (test-dto) dict 'skipped)))
  (test-group "group with multiple tests"
    (define dict
      (parameterize ((test-info 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)))))
        (test-info-dict)))
    (begin
      (test-eqv "passed number" 2 (dict-ref (test-dto) dict 'passed))
      (test-eqv "tests number" 4 (dict-ref (test-dto) dict 'tests))
      (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed))
      (test-eqv "skipped number" 1 (dict-ref (test-dto) dict 'skipped))))
  (test-group "nested groups"
    (define inner-dict #f)
    (define dict
      (parameterize ((test-info silent-dict))
        (test-group "gr1"
          (test-body #f #t)
          (test-group "gr2"
            (test-body #f
              (set! inner-dict (test-info-dict))
              #f)))
        (inspect-test-info values)))
    (test-eqv "passed number" 1 (dict-ref (test-dto) dict 'passed))
    (test-eqv "tests number" 2 (dict-ref (test-dto) dict 'tests))
    (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed))
    (test-eqv "skipped number" 0 (dict-ref (test-dto) dict 'skipped))
    (test-eqv "inner name" #f (dict-ref (test-dto) inner-dict 'name))
    (test-equal "inner name stack" '("gr2" "gr1")
                (dict-ref (test-dto) inner-dict 'name-stack))))

(test-group "test named application"
  (test-body "true"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-named-application "not" (not not) (arg #f))
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'passed)))
  (test-body "false"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-named-application "not" (not not) (arg #t))
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'failed))))

(test-group "test-equal"
  (test-body "true"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-equal "equal" "abc" "abc")
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'passed)))
  (test-body "false"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-equal "equal" "abc" "def")
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'failed))))

(test-group "test-eq"
  (test-body "true"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-eq "eq" 'abc 'abc)
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'passed)))
  (test-body "false"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-eq "eq" 'abc 'def)
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'failed))))

(test-group "test-eqv"
  (test-body "true"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-eqv "eqv" 100 100)
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'passed)))
  (test-body "false"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-eqv "eqv" 100 200)
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'failed))))

(test-group "test-approximate"
  (test-body "true"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-approximate "approx" 1 1.001 0.01)
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'passed)))
  (test-body "false"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-approximate "approx" 100 1.01 0.01)
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'failed))))

(test-group "test-error"
  (test-body "thrown exception"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-error #f
          (lambda (ex) (equal? ex "exception"))
          (raise "exception"))
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'passed)))
  (test-body "no thrown exception"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-error #f
          (lambda (ex) #t)
          #t)
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'failed)))
  (test-body "incorrectly thrown exception"
    (define dict
      (parameterize ((test-info silent-dict))
        (test-error #f number? (raise "exception"))
        (test-info-dict)))
    (eqv? 1 (dict-ref (test-dto) dict 'failed))))

(test-group "expect-to-fail"
  (expect-to-fail
    (test-body "1 = 2" (eqv? 1 2))
    (cond-expand
      ;; SKINT will actually raise a noncatchable error here!
      ((not skint) (test-body "type error" (car '())))
      (else #f))))

(test-exit)