diff --git a/d-/test.scm b/d-/test.scm new file mode 100644 index 0000000..18eaea7 --- /dev/null +++ b/d-/test.scm @@ -0,0 +1,37 @@ +(define-module (d- test) + #:use-module (ice-9 format) + #:use-module (ice-9 control) + #:export (define-test-suite assert)) + +(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))])))) diff --git a/test.scm b/test.scm index 5b539bd..9884747 100644 --- a/test.scm +++ b/test.scm @@ -1,98 +1,64 @@ (use-modules (d-) - (rnrs base) + (d- test) (srfi srfi-1)) -;; TODO eventually these will be cool prompt thingies +(define-test-suite "~>" + (define-test "unwrapped" + (define value (~> 1 1+ 1+)) + (assert-equal 3 value)) + (define-test "wrapped" + (define value (~> 1 (/ 2) (/ 2))) + (assert-equal 1/4 value))) -(define (assert-equal a b) - (display "... ") - (if (equal? a b) - (display "OK") - (begin - (display "expected ") - (display b) - (display " but instead got ") - (display a)))) +(define-test-suite "~>>" + (define-test "unwrapped" + (define value (~>> 1 1+ 1+)) + (assert-equal 3 value)) + (define-test "wrapped" + (define value (~>> 1 (/ 2) (/ 2))) + (assert-equal 1 value))) -(define (assert-unspecified a) - (display "... ") - (if (unspecified? a) - (display "OK") - (begin - (display "expected unspecifed but instead got ") - (display a)))) +(define-test-suite "if-not" + (define-test "test" + (assert-equal 'a (if-not #f 'a 'b)))) -(define-syntax-rule (define-unit-test (test-name body ...)) - (let () - (display "< ") - (display (symbol->string 'test-name)) - body ... - (newline))) +(define-test-suite "when-not" + (define-test "positive-case" + (assert-equal 'return (when-not #f 'do-some-stuff 'return))) + (define-test "negative-case" + (assert-unspecified (when-not #t 'do-some-stuff 'return)))) -(define-syntax-rule (define-test module-name tests ...) - (begin - (display "> ") - (display (symbol->string 'module-name)) - (newline) - (define-unit-test tests) ...)) +(define-test-suite "for" + (define-test "permutation" + (define value (for ([i (iota 2)] + [j (iota 2)]) + (cons i j))) + (assert-equal '((0 . 0) (0 . 1) (1 . 0) (1 . 1)) value))) -(define-test ~> - (unwrapped - (define value (~> 1 1+ 1+)) - (assert-equal value 3)) - (wrapped - (define value (~> 1 (/ 2) (/ 2))) - (assert-equal value 1/4))) +(define-test-suite "if-let" + (define-test "positive-case" + (assert-equal 2 (if-let ([v (or #f 1)]) (+ v 1)))) + (define-test "negative-case" + (assert-equal #f (if-let ([v (and #f 1)]) (+ v 1))))) -(define-test ~>> - (unwrapped - (define value (~>> 1 1+ 1+)) - (assert-equal value 3)) - (wrapped - (define value (~>> 1 (/ 2) (/ 2))) - (assert-equal value 1))) +(define-test-suite "partial" + (define-test "test" + (define value (partial / 2)) + (assert-equal 1/2 (value 4)) + (assert-equal 2 (value 1)))) -(define-test if-not - (test - (assert-equal (if-not #f 'a 'b) 'a))) +(define-test-suite "argmin" + (define-test "test" + (assert-equal '(b . 2) (argmin cdr < '(a . 5) '(b . 2) '(c . 3))))) -(define-test when-not - (positive-case - (assert-equal (when-not #f 'do-some-stuff 'return) 'return)) - (negative-case - (assert-unspecified (when-not #t 'do-some-stuff 'return)))) - -(define-test for - (permutation - (define value (for ([i (iota 2)] - [j (iota 2)]) - (cons i j))) - (assert-equal value '((0 . 0) (0 . 1) (1 . 0) (1 . 1))))) - -(define-test if-let - (positive-case - (assert-equal (if-let ([v (or #f 1)]) (+ v 1)) 2)) - (negative-case - (assert-equal (if-let ([v (and #f 1)]) (+ v 1)) #f))) - -(define-test partial - (test - (define value (partial / 2)) - (assert-equal (value 4) 1/2) - (assert-equal (value 1) 2))) - -(define-test argmin - (test - (assert-equal (argmin cdr < '(a . 5) '(b . 2) '(c . 3)) '(b . 2)))) - -(define-test generator - (test - (define number-generator - (generator - (let loop ([i 1]) - (yield i) - (loop (1+ i))))) - (assert-equal (number-generator) 1) - (assert-equal (number-generator) 2) - (assert-equal (number-generator) 3) - (assert-equal (number-generator) 4))) +(define-test-suite "generator" + (define-test "test" + (define number-generator + (generator + (let loop ([i 1]) + (yield i) + (loop (1+ i))))) + (assert-equal 1 (number-generator)) + (assert-equal 2 (number-generator)) + (assert-equal 3 (number-generator)) + (assert-equal 4 (number-generator))))