assert-test.ss
(module assert-test mzscheme
  
  (require (lib "list.ss" "srfi" "1")
           "test.ss")
  
  (provide assert-tests)
  
  
  (define (make-failure-test name pred . args)
    (make-test-case
     name
     (assert-exn exn:test:assertion?
                 (lambda ()
                   (apply pred args)))))

  (define-assertion (good)
    #t)

  (define-assertion (bad)
    (fail-assertion))
  
  (define assert-tests
    (make-test-suite
     "Assert tests"
     ; Successes
     (make-test-case "Simple assert-equal? test"
                     (assert-equal? 1 1))
     (make-test-case "Simple assert-eq? test"
                     (assert-eq? 'a 'a))
     (make-test-case "Simple assert-eqv? test"
                     (assert-eqv? 'a 'a))
     (make-test-case "Simple assert test"
                     (assert string=? "hello" "hello"))
     (make-test-case "Simple assert-true test"
                     (assert-true (eq? 'a 'a)))
     (make-test-case "Simple assert-pred test"
                     (assert-pred null? (list)))
     (make-test-case "Simple assert-exn test"
                     (assert-exn exn:test:assertion?
                                 (lambda ()
                                   (assert = 1 2))))
     (make-test-case "Simple assert-not-exn test"
                     (assert-not-exn
                      (lambda ()
                        (assert = 1 1))))
     (make-test-case "Defined assertion succeeds"
                     (good))
     (make-test-case "Simple assert-not-false test"
                     (assert-not-false 3))
     
     (make-test-case "Use of assertion as expression"
                     (for-each assert-false '(#f #f #f)))
     (make-test-case "Use of local assertion as expression"
                     (let ()
                       (define-simple-assertion (assert-symbol? x)
                         (symbol? x))
                       (for-each assert-symbol? '(a b c))))
     
     ; Failures
     (make-failure-test "assert-equal? failure"
                        assert-equal?* 1 2)
     (make-failure-test "assert-eq? failure"
                        assert-eq?* 'a 'b)
     (make-failure-test "assert-eqv? failure"
                        assert-eqv?* 'a 'b)
     (make-failure-test "assert failure"
                        assert* string=? "hello" "bye")
     (make-failure-test "assert-true failure"
                        assert-true* (eq? 'a 'b))
     (make-failure-test "assert-pred failure"
                        assert-pred* null? (list 1 2 3))
     (make-failure-test "assert-exn failure"
                        assert-exn* exn:test:assertion? (lambda () (assert = 1 1)))
     (make-failure-test "assert-exn wrong exception"
                        assert-exn* exn:fail:contract:arity? (lambda () (+ 1 2)))
     (make-failure-test "assert-not-exn"
                        assert-not-exn* (lambda () (/ 1 0)))
     (make-failure-test "fail with message failure"
                        fail* "With message")
     (make-failure-test "fail without message failure"
                        fail*)
     (make-failure-test "Defined assertion fails"
                        bad*)
     (make-failure-test "assert-not-false failure"
                        assert-not-false* #f)

     (make-test-case "assertion-as-expression failure"
                     (assert-exn exn:test:assertion?
                                 (lambda ()
                                   (for-each assert-false '(#f not-false)))))
     
     (make-test-case
      "Assertion allows optional message"
      (begin
        (assert* = 1 1 "message")
        (assert = 1 1 "message")))

     ;; Some necessary semantics
     (make-test-case
      "Assertion macro parameters evaluated once"
      (let ((counter 0))
        (assert-true (begin (set! counter (add1 counter))
                            #t))
        (assert = counter 1)))
     (make-test-case
      "Assertion function parameters evaluated once"
      (let ((counter 0))
        (assert-true* (begin (set! counter (add1 counter))
                             #t))
        (assert = counter 1)))

     ;; Exceptions have the correct types
     (make-test-case
      "Macro w/ no message, message is a string"
      (let ((exn (with-handlers ([exn? (lambda (exn)
                                         exn)])
                                (assert-true #f))))
        (assert-pred string? (exn-message exn))))
     (make-test-case
      "Function w/ no message, message is a string"
      (let ((exn (with-handlers ([exn? (lambda (exn)
                                         exn)])
                                (assert-true* #f))))
        (assert-pred string? (exn-message exn))))

     ;; The assertion construction language
     (make-test-case
      "with-assertion-info* captures information"
      (let ((name (make-assertion-info 'name "name"))
            (info (make-assertion-info 'info "info")))
        (with-handlers
            [(exn:test:assertion?
              (lambda (exn)
                (let ((stack (exn:test:assertion-stack exn)))
                  (assert = (length stack) 2)
                         (let ((actual-name (first stack))
                               (actual-info (second stack)))
                           (assert-equal? name actual-name)
                           (assert-equal? info actual-info)))))]
          (with-assertion-info*
           (list name info)
           (lambda ()
             (fail-assertion))))))
     (make-test-case
      "with-assertion-info captures information"
      (with-handlers
          [(exn:test:assertion?
            (lambda (exn)
              (let ((stack (exn:test:assertion-stack exn)))
                (assert = (length stack) 2) 
                (let ((name (first stack))
                      (info (second stack)))
                  (assert-eq? (assertion-info-name name) 'name)
                  (assert string=? (assertion-info-value name) "name")
                  (assert-eq? (assertion-info-name info) 'info)
                  (assert string=? (assertion-info-value info) "info")))))]
        (with-assertion-info
         (('name "name") ('info "info"))
         (fail-assertion))))
     (make-test-case
      "assertion information stack nesting"
      (with-handlers
          [(exn:test:assertion?
            (lambda (exn)
              (let ((stack (exn:test:assertion-stack exn)))
                (assert = (length stack) 4)
                (assert string=?
                        (assertion-info-value (first stack))
                        "name2"))))] 
        (with-assertion-info
         (('name "name") ('info "info"))
         (with-assertion-info
          (('name "name2") ('info "info2"))
          (fail-assertion)))))
     (make-test-case
      "assertion information stack unwinds"
      (with-handlers
          [(exn:test:assertion?
            (lambda (exn)
              (let ((stack (exn:test:assertion-stack exn)))
                (assert = (length stack) 2) 
                (let ((name (first stack))
                      (info (second stack)))
                  (assert-eq? (assertion-info-name name) 'name)
                  (assert string=? (assertion-info-value name) "name")
                  (assert-eq? (assertion-info-name info) 'info)
                  (assert string=? (assertion-info-value info) "info")))))]
        (with-assertion-info
         (('name "name") ('info "info"))
         (with-assertion-info
          (('name "name") ('info "info"))
          #t)
         (fail-assertion))))

     ;; If assert-exn isn't working correctly many tests above will
     ;; silently fail.  Here we test assert-exn is working.
     (make-test-case
      "assert-exn traps exception"
      (with-handlers
          ((exn?
            (lambda (exn) (fail "Received exception"))))
        (assert-exn exn:fail:contract:arity?
                    (lambda () (= 1)))))
     (make-test-case
      "assert-exn fails if no exception raised"
      (with-handlers
          ((exn:test:assertion?
            (lambda (exn) #t))
           (exn:fail:contract:arity?
            (lambda (exn) (fail "assert-exn didn't fail"))))
        (assert-exn exn? (lambda () (= 1 1)))
        (= 1)))
     
     ))
  )