38 lines
1.3 KiB
Scheme
38 lines
1.3 KiB
Scheme
(define-module (d- test)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 control)
|
|
#:export (define-test-suite))
|
|
|
|
(define (assert expected actual eq? fail)
|
|
(when (not (eq? expected actual))
|
|
(format #t "fail - expected ~a but got ~a" expected actual)
|
|
(newline)
|
|
(fail)))
|
|
|
|
(define-syntax define-test-suite
|
|
(lambda (stx)
|
|
(with-syntax ([fail (datum->syntax stx 'fail)])
|
|
(define (assert-stx expr)
|
|
(syntax-case expr (assert-equal assert-not-equal)
|
|
[(assert-equal e a) #'(assert e a equal? fail)]
|
|
[(assert-not-equal e a) #'(assert e a (compose not equal?) fail)]
|
|
[(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)]
|
|
[else #'else]))
|
|
(define (define-test-stx test)
|
|
(syntax-case test (define-test)
|
|
[(define-test test-name e ...)
|
|
#`(call/ec (lambda (fail)
|
|
(format #t "~a: " test-name)
|
|
(begin
|
|
#,@(map assert-stx #'(e ...)))
|
|
(display "ok")
|
|
(newline)))]))
|
|
(syntax-case stx ()
|
|
[(define-test-suite name test ...)
|
|
#`(begin
|
|
(format #t "Suite ~a:" name)
|
|
(newline)
|
|
#,@(map define-test-stx
|
|
#'(test ...))
|
|
(newline))]))))
|