diff --git a/d-/test.scm b/d-/test.scm index 66121cf..bb164fc 100644 --- a/d-/test.scm +++ b/d-/test.scm @@ -2,15 +2,31 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 format) #:use-module (ice-9 control) - #:export (define-test-suite anything)) + #:export (define-test-suite + assert-equal assert-not-equal assert-unspecified + anything)) (define *anysym* (gensym)) (define (anything) *anysym*) -(define (assert expected actual eq? fail) - (when (and (not (eq? expected actual))) +(define *fail* (make-parameter #f)) + +(define (assert expected actual eq?) + (cond + [(not (*fail*)) (error "assertion outside test context")] + [(not (eq? expected actual)) (format #t "fail - expected ~a but got ~a~%" expected actual) - (fail))) + ((*fail*))] + [else #t])) + +(define (assert-equal e a) + (assert e a equal-or-any?)) + +(define (assert-not-equal e a) + (assert e a (compose not equal-or-any?))) + +(define (assert-unspecified v) + (assert (when #f '_) v eq?)) (define (equal-or-any? expected actual) (cond @@ -22,27 +38,21 @@ (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-unspecified) - [(assert-equal e a) #'(assert e a equal-or-any? fail)] - [(assert-not-equal e a) #'(assert e a (compose not equal-or-any?) 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))])))) + (define (define-test-stx test) + (syntax-case test (define-test) + [(define-test test-name e ...) + #`(call/ec + (lambda (fail) + (parameterize ([*fail* fail]) + (format #t "~a: " test-name) + 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))]))) diff --git a/test.scm b/test.scm index c223887..0116b50 100644 --- a/test.scm +++ b/test.scm @@ -200,16 +200,19 @@ (define solution (get-solution)) (assert-equal 'norwegian (assq-ref solution '?water-drinker)) (assert-equal 'japanese (assq-ref solution '?zebra-owner))) + (define-test "with-db" (define my-db '()) (define get-solution #f) (define solution #f) (with-db my-db (<- (foo bar))) + ;; Outside context (set! get-solution (?- (foo ?x))) (set! solution (get-solution)) (assert-equal #f (assq-ref solution '?x)) + ;; Inside context (with-db my-db (set! get-solution (?- (foo ?x))) - (set! solution (get-solution))) - (assert-equal 'bar (assq-ref solution '?x)))) + (set! solution (get-solution)) + (assert-equal 'bar (assq-ref solution '?x)))))