(module assert-util-test mzscheme
(require "test.ss"
"assert-util.ss"
"assert-base.ss")
(provide assert-util-tests)
(define assert-util-tests
(make-test-suite
"All assert-util tests"
(make-test-case
"syntax->location-values ok"
(assert equal?
'("assert-util-test.ss" 42 38 1240 2 #f)
(syntax->location-values
(datum->syntax-object #f '() (list "assert-util-test.ss" 42 38 1240 2) #f))))
(make-test-case
"Emacs compatible location strings"
(begin
(assert string=?
(location->string (list "file.ss" 42 38 1240 2 #f))
"file.ss:42:38")
(assert string=?
(location->string (list #f 42 38 1240 2 #f))
"unknown:42:38")
(assert string=?
(location->string (list 'foo.ss 42 38 1240 2 #f))
"foo.ss:42:38")))
(make-test-case
"Stack inspection functions are correct"
(with-handlers
((exn:test:assertion?
(lambda (exn)
(let ((stack (exn:test:assertion-stack exn)))
(assert-eq? (get-assertion-location stack)
'location)
(assert-eq? (get-assertion-name stack)
'name)
(assert-eq? (get-assertion-params stack)
'params)
(assert-eq? (get-assertion-expression stack)
'expression)
(assert-eq? (get-assertion-message stack)
'message)
(assert-eq? (get-assertion-info 'foo stack) 'bar)
(assert-eq? (get-assertion-info 'not-there stack)
#f)))))
(with-assertion-info*
(list
(make-assertion-name 'name)
(make-assertion-params 'params)
(make-assertion-location 'location)
(make-assertion-expression 'expression)
(make-assertion-message 'message)
(make-assertion-info 'foo 'bar))
(lambda ()
(fail-assertion)))))
(make-test-case
"Stack inspection functions find latest values"
(with-handlers
((exn:test:assertion?
(lambda (exn)
(let ((stack (exn:test:assertion-stack exn)))
(assert-eq? (get-assertion-location stack)
'location)))))
(with-assertion-info*
(list (make-assertion-location 'foo))
(lambda ()
(with-assertion-info*
(list (make-assertion-location 'location))
(lambda ()
(fail-assertion)))))))
(make-test-case
"Stack inspection functions handle empty stack"
(begin
(assert-eq? (get-assertion-location null)
#f)
(assert-eq? (get-assertion-name null)
#f)
(assert-eq? (get-assertion-params null)
#f)
(assert-eq? (get-assertion-expression null)
#f)
(assert-eq? (get-assertion-message null)
#f)
(assert-eq? (get-assertion-info 'foo null) #f)
(assert-eq? (get-assertion-info 'not-there null)
#f)))
))
)