(require (lib "test.ss" "schemeunit")
(lib "class.ss")
(lib "assert-test.ss" "schemeunit")
(lib "assert-util-test.ss" "schemeunit")
(lib "test-test.ss" "schemeunit")
(lib "graphical-ui.ss" "schemeunit")
(lib "text-ui.ss" "schemeunit"))
(define ui 'graphical)
(define register
(case ui
([graphical] test/graphical-ui)
([text] (lambda (suite bool) (test/text-ui suite)))))
(register
(make-test-suite "Various tests"
assert-tests
assert-util-tests
test-tests
(make-test-case "A solitary test case"
(assert-equal? 'apple (string->symbol "apple")))
(make-test-suite "An empty test suite")
(make-test-suite
"Problems..."
(make-test-case "Should be okay"
(begin
(assert-true (even? 44))
(void)))
(make-test-case "Also okay"
(assert-exn void (lambda () (error 'throws "exception"))))
(make-test-case "This case should fail"
(begin
(+ 47
(if (zero? 2)
(* 8 9)
(assert-equal? 4 5)))
(void)))
(make-test-case "Another failure, on a primitive function"
(assert-pred positive? (* 13 -1)))
(make-test-case "Doesn't work, either"
(assert = 1 2))
(make-test-case "Failure of anonymous predicate"
(assert-pred
(lambda (x) #f)
4))
(make-test-case "This causes error"
(cons 4))
(make-test-suite "A nested suite"
(make-test-case "Fine"
(and (assert-equal? 4 (sub1 5))
(assert-eq? 'hi 'hi)))
(make-test-case "Unfine"
(assert-exn (lambda _ #f)
(lambda () (error 'test "look over there!"))))
(make-test-case "Subtle (error)"
(assert-exn
(lambda _ #f)
(error 'test "I'm evaluated *before* assert-exn is applied")))
(make-test-case "Flat fail" (fail)))
(make-test-case "Another error (causes output)"
(begin
(printf "Here's some output")
(fprintf (current-error-port) "talking to error port")
(printf " which will probably be interleaved and all")
(fprintf (current-error-port)
"(but at least it should be marked properly).")
(error 'whoa "made a mistake")))
(make-test-case "Error with interesting backtrace"
(let [(foo (+ 3 (/ 1 0)))]
foo))
(make-test-case "Weird"
(begin
(let [(cms (let/cc k (continuation-marks k)))]
(raise (make-exn:user "gotcha" cms)))
(void)))
(make-test-case "Raise non-exn-struct"
(raise 'not-an-exn))
))
#t)