diff options
| -rw-r--r-- | format-test.csc | 61 | ||||
| -rw-r--r-- | format.csc | 33 | ||||
| -rw-r--r-- | hash-map-test.csc | 132 | ||||
| -rw-r--r-- | list-test.csc | 214 | ||||
| -rw-r--r-- | match-test.csc | 114 | ||||
| -rw-r--r-- | sort-test.csc | 70 | ||||
| -rw-r--r-- | strings-test.csc | 113 | ||||
| -rw-r--r-- | testing.csc | 101 | ||||
| -rw-r--r-- | vec-test.csc | 109 |
9 files changed, 310 insertions, 637 deletions
diff --git a/format-test.csc b/format-test.csc index b7b2c99..6efaa87 100644 --- a/format-test.csc +++ b/format-test.csc @@ -1,47 +1,24 @@ (import (scheme base) (only (csc strings) str-quote) - (only (csc testing) define-test errorf subtest) + (only (csc testing) assert-equal test) (csc format)) -(define-test (test-vsprintf t) - (define-record-type <test-case> - (test-case name fmt args want) - test-case? - (name name) - (fmt fmt) - (args args) - (want want)) - (let ((tests (list - (test-case - "single-string" - "test-string" - '() - "test-string") - (test-case - "list" - "{}" - '((1 2 3)) - "(1 2 3)") - (test-case - "complex" - "this {} is {} a {} test" - '((1 2 3) 1 "bbb") - "this (1 2 3) is 1 a bbb test") - (test-case - "escape open" - "{{" - '() - "{") - (test-case - "escape close" - "}}" - '() - "}")))) - (for-each - (lambda (tc) - (subtest t (name tc) - (let ((got (vsprintf (fmt tc) (args tc)))) - (unless (equal? got (want tc)) - (errorf t "(vsprintf {} {}) = {}, want {}." (str-quote fmt) (args tc) got (want tc)))))) - tests))) +(test sprintf-single-string + (assert-equal "test-string" (sprintf "test-string"))) + + +(test sprintf-list + (assert-equal "(1 2 3)" (sprintf "{}" '(1 2 3)))) + + +(test sprintf-complex + (assert-equal "this (1 2 3) is 1 a bbb test" (sprintf "this {} is {} a {} test" '(1 2 3) 1 "bbb"))) + + +(test sprintf-escape-open + (assert-equal "{" (sprintf "{{"))) + + +(test sprintf-escape-close + (assert-equal "}" (sprintf "}}"))) @@ -1,10 +1,7 @@ (define-library (csc format) (export - vfprintf fprintf - vprintf printf - vsprintf sprintf) (import (scheme base) (only (scheme write) display) @@ -15,7 +12,7 @@ (begin - (define (vfprintf port format-string format-args) + (define (fprintf port format-string . format-args) (let loop ((start 0) (args format-args)) (cond ((>= start (string-length format-string))) @@ -42,29 +39,11 @@ (loop format-pos args)))))) - (define-syntax fprintf - (syntax-rules () - ((_ port format-string format-args ...) - (vfprintf port format-string (list format-args ...))))) + (define (printf format-string . format-args) + (apply fprintf (current-output-port) format-string format-args)) - (define (vprintf format-string format-args) - (vfprintf (current-output-port) format-string format-args)) - - - (define-syntax printf - (syntax-rules () - ((_ format-string format-args ...) - (vprintf format-string (list format-args ...))))) - - - (define (vsprintf format-string format-args) + (define (sprintf format-string . format-args) (let ((string-builder (open-output-string))) - (vfprintf string-builder format-string format-args) - (get-output-string string-builder))) - - - (define-syntax sprintf - (syntax-rules () - ((_ format-string format-args ...) - (vsprintf format-string (list format-args ...))))))) + (apply fprintf string-builder format-string format-args) + (get-output-string string-builder))))) diff --git a/hash-map-test.csc b/hash-map-test.csc index 8f51dfa..b1b98bd 100644 --- a/hash-map-test.csc +++ b/hash-map-test.csc @@ -1,9 +1,8 @@ (import (scheme base) (only (csc sort) sort) (only (csc testing) - define-test - errorf - subtest) + assert-equal + test) (csc hash-map)) @@ -15,84 +14,53 @@ (string<? (symbol->string s1) (symbol->string s2))) -(define-test (test-hash-map->alist t) - (define-record-type <test-case> - (test-case desc vals) - test-case? - (desc desc) - (vals vals)) - (let ((tests (list - (test-case - "singleton" - '((a . 1))) - (test-case - "two" - '((a . 1) (b . 2))) - (test-case - "longer" - '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))))) - (for-each - (lambda (tc) - (subtest t (desc tc) - (let* ((m (alist->hash-map hash-symbol symbol<? (vals tc))) - (got (hash-map->alist m))) - (unless (equal? - (sort - (lambda (x1 x2) (symbol<? (car x1) (car x2))) - got) - (sort - (lambda (x1 x2) (symbol<? (car x1) (car x2))) - (vals tc))) - (errorf t "(hash-map->alist {}) = {}, want {}." m got (vals tc)))))) - tests))) +(define (alist->hash-map->alist l) + (hash-map->alist (alist->hash-map hash-symbol symbol<? l))) -(define-test (test-alist->hash-map t) - (define-record-type <test-case> - (test-case desc vals want) - test-case? - (desc desc) - (vals vals) - (want want)) - (let ((tests (list - (test-case - "singleton" - '((a . 1)) - '((a . 1))) - (test-case - "two" - '((a . 1) (b . 2)) - '((a . 1) (b . 2))) - (test-case - "larger" - '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8)) - '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8))) - (test-case - "in-order" - '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())) - '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) - (test-case - "reversed" - '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ())) - '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) - (test-case - "overwrite" - '((a . 1) (a . 2)) - '((a . 2))) - (test-case - "alternating" - '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ())) - '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ())))))) - (for-each - (lambda (tc) - (subtest t (desc tc) - (let ((got (alist->hash-map hash-symbol symbol<? (vals tc)))) - (unless (equal? - (sort - (lambda (x1 x2) (symbol<? (car x1) (car x2))) - (hash-map->alist got)) - (sort - (lambda (x1 x2) (symbol<? (car x1) (car x2))) - (want tc))) - (errorf t "(alist->hash-map {}) = {}, want {}." (vals tc) (hash-map->alist got) (want tc)))))) - tests))) +(define (sort-alist l) + (sort (lambda (x1 x2) (symbol<? (car x1) (car x2))) l)) + + +(test hash-map->alist-singleton + (assert-equal (sort-alist '((a . 1))) (sort-alist (alist->hash-map->alist '((a . 1)))))) + + +(test hash-map->alist-two + (assert-equal (sort-alist '((a . 1) (b . 2))) (sort-alist (alist->hash-map->alist '((a . 1) (b . 2)))))) + + +(test hash-map->alist-longer + (assert-equal + (sort-alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) + (sort-alist (alist->hash-map->alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))))) + + +(test hash-map->alist-larger + (assert-equal + (sort-alist '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8))) + (sort-alist (alist->hash-map->alist '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8)))))) + + +(test hash-map->alist-in-order + (assert-equal + (sort-alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) + (sort-alist (alist->hash-map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))) + + +(test hash-map->alist-reversed + (assert-equal + (sort-alist '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ()))) + (sort-alist (alist->hash-map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))) + + +(test hash-map->alist-overwrite + (assert-equal + (sort-alist '((a . 2))) + (sort-alist (alist->hash-map->alist '((a . 1) (a . 2)))))) + + +(test hash-map->alist-alternating + (assert-equal + (sort-alist '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ()))) + (sort-alist (alist->hash-map->alist '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ())))))) diff --git a/list-test.csc b/list-test.csc index e4981e5..d4ea504 100644 --- a/list-test.csc +++ b/list-test.csc @@ -1,159 +1,75 @@ (import (scheme base) - (only (csc testing) define-test errorf) + (only (csc testing) assert assert-equal test) (csc list)) -(define-test (test-take t) - (define-record-type <test-case> - (test-case desc n xs want) - test-case? - (desc desc) - (n n) - (xs xs) - (want want)) - (let ((tests (list - (test-case - "simple" - 3 - '(1 2 3 4 5) - '(1 2 3)) - (test-case - "negative" - -5 - '(1 2 3) - '()) - (test-case - "zero" - 0 - '(1 2 3) - '()) - (test-case - "short list" - 5 - '(1 2 3) - '(1 2 3)) - (test-case - "take whole list" - 3 - '(1 2 3) - '(1 2 3))))) - (for-each - (lambda (tc) - (let ((got (take (n tc) (xs tc)))) - (unless (equal? got (want tc)) - (errorf t "(got {} {}) = {}, want {}." (n tc) (xs tc) got (want tc))))) - tests))) +(test take-simple + (assert-equal '(1 2 3) (take 3 '(1 2 3 4 5)))) -(define-test (test-split-at t) - (define-record-type <test-case> - (test-case desc n xs want-a want-b) - test-case? - (desc desc) - (n n) - (xs xs) - (want-a want-a) - (want-b want-b)) - (let ((tests (list - (test-case - "simple" - 2 - '(1 2 3 4) - '(1 2) - '(3 4)) - (test-case - "negative" - -5 - '(1 2 3) - '() - '(1 2 3)) - (test-case - "zero" - 0 - '(1 2 3) - '() - '(1 2 3)) - (test-case - "short list" - 5 - '(1 2 3) - '(1 2 3) - '()) - (test-case - "whole list" - 3 - '(1 2 3) - '(1 2 3) - '())))) - (for-each - (lambda (tc) - (let-values (((got-a got-b) (split-at (n tc) (xs tc)))) - (unless (equal? got-a (want-a tc)) - (errorf t "(split-at {} {}) = (values {}, _), want {}." (n tc) (xs tc) got-a (want-a tc))) - (unless (equal? got-b (want-b tc)) - (errorf t "(split-at {} {}) = (values _, {}), want {}." (n tc) (xs tc) got-b (want-b tc))))) - tests))) +(test take-negative + (assert-equal '() (take -5 '(1 2 3)))) -(define-test (test-revappend t) - (define-record-type <test-case> - (test-case desc a b want) - test-case? - (desc desc) - (a a) - (b b) - (want want)) - (let ((tests (list - (test-case - "threes" - '(3 2 1) - '(4 5 6) - '(1 2 3 4 5 6)) - (test-case - "empty first list" - '() - '(1 2 3) - '(1 2 3)) - (test-case - "empty second list" - '(3 2 1) - '() - '(1 2 3))))) - (for-each - (lambda (tc) - (let ((got (revappend (a tc) (b tc)))) - (unless (equal? got (want tc)) - (errorf t "(revappend {} {}) = {}, want {}." (a tc) (b tc) got (want tc))))) - tests))) +(test take-zero + (assert-equal '() (take 0 '(1 2 3)))) -(define-test (test-intercalate t) - (define-record-type <test-case> - (test-case desc x l want) - test-case? - (desc desc) - (x x) - (l l) - (want want)) - (let ((tests (list - (test-case - "simple" - "," - '("a" "b" "c") - '("a" "," "b" "," "c")) - (test-case - "empty" - "," - '() - '()) - (test-case - "singleton" - "," - '(1) - '(1))))) - (for-each - (lambda (tc) - (let ((got (intercalate (x tc) (l tc)))) - (unless (equal? got (want tc)) - (errorf t "(intercalate {} {}) = {}, want {}." (x tc) (l tc) got (want tc))))) - tests))) +(test take-short-list + (assert-equal '(1 2 3) (take 5 '(1 2 3)))) + + +(test take-whole-list + (assert-equal '(1 2 3) (take 3 '(1 2 3)))) + + +(define-syntax values= + (syntax-rules () + ((values= x y) + (let-values (((x-a x-b) x) + ((y-a y-b) y)) + (and (equal? x-a y-a) (equal? x-b y-b)))))) + + +(test split-at-simple + (assert (values= (values '(1 2) '(3 4)) (split-at 2 '(1 2 3 4))))) + + +(test split-at-negative + (assert (values= (values '() '(1 2 3)) (split-at -5 '(1 2 3))))) + + +(test split-at-zero + (assert (values= (values '() '(1 2 3)) (split-at 0 '(1 2 3))))) + + +(test split-at-short-list + (assert (values= (values '(1 2 3) '()) (split-at 5 '(1 2 3))))) + + +(test split-at-whole-list + (assert (values= (values '(1 2 3) '()) (split-at 3 '(1 2 3))))) + + +(test revappend-threes + (assert-equal '(1 2 3 4 5 6) (revappend '(3 2 1) '(4 5 6)))) + + +(test revappend-empty-first-list + (assert-equal '(1 2 3) (revappend '() '(1 2 3)))) + + +(test revappend-empty-second-list + (assert-equal '(1 2 3) (revappend '(3 2 1) '()))) + + +(test intercalate-simple + (assert-equal '("a" "," "b" "," "c") (intercalate "," '("a" "b" "c")))) + + +(test intercalate-empty + (assert-equal '() (intercalate "," '()))) + + +(test intercalate-singleton + (assert-equal '(1) (intercalate "," '(1)))) diff --git a/match-test.csc b/match-test.csc index 104581b..84b488d 100644 --- a/match-test.csc +++ b/match-test.csc @@ -1,63 +1,59 @@ (import (scheme base) - (only (csc testing) define-test errorf subtest) + (only (csc testing) assert-equal test) (csc match)) -(define-test (test-match t) - (define-record-type <test-case> - (test-case name expr want) - test-case? - (name name) - (expr expr) - (want want)) - (let ((tests (list - (test-case - "cond" - (match 3 - (0 0) - (1 1) - (2 2) - (3 3) - (_ 4)) - 3) - (test-case - "match-list" - (match '(1 2 3) - ('() 0) - ((1 2) 1) - ((1 2 3) 2) - ((1 2 3 4) 3) - (_ 4)) - 2) - (test-case - "binding" - (match '(1 2 3) - ((1 x 3) x)) - 2) - #;(test-case - "destructuring" - (match '(1 2 3) - ('() 0) - ((head . _) head)) - 1) - #;(test-case - "ignore" - (match '(1 2 3) - ((_ _ _ _) 0) - ((2 _ _) 1) - ((1 _ _) 2) - (_ 3)) - 2) - #;(test-case - "improper list" - (match '(1 2 3) - ((2 . _) 1) - ((1 . x) (car x)) - (_ 3)) - 2)))) - (for-each - (lambda (tc) - (subtest t (name tc) - (unless (equal? (expr tc) (want tc)) - (errorf t "match = {}, want {}." (expr tc) (want tc))))) - tests))) +(test match-cond + (assert-equal + 3 + (match 3 + (0 0) + (1 1) + (2 2) + (3 3) + (_ 4)))) + + +(test match-list + (assert-equal + 2 + (match '(1 2 3) + ('() 0) + ((1 2) 1) + ((1 2 3) 2) + ((1 2 3 4) 3) + (_ 4)))) + + +(test match-binding + (assert-equal + 2 + (match '(1 2 3) + ((1 x 3) x)))) + + +(test match-destructuring + (assert-equal + 1 + (match '(1 2 3) + ('() 0) + ((head . _) head)))) + + +(test match-ignore + (assert-equal + 2 + (match '(1 2 3) + ((_ _ _ _) 0) + ((2 _ _) 1) + ((1 _ _) 2) + (_ 3)))) + + +(test match-improper-list + (assert-equal + 2 + (match '(1 2 3) + ((2 . _) 1) + ((1 . x) (car x)) + (_ 3)))) diff --git a/sort-test.csc b/sort-test.csc index b922484..dec2a53 100644 --- a/sort-test.csc +++ b/sort-test.csc @@ -1,45 +1,35 @@ (import (scheme base) (only (csc testing) - define-test - errorf) + assert-equal + test) (csc sort)) -(define-test (test-sort t) - (define-record-type <test-case> - (test-case desc xs want) - test-case? - (desc desc) - (xs xs) - (want want)) - (let ((tests (list - (test-case - "ten elem" - '(9 4 5 100 3 2 4 6 0 -2) - '(-2 0 2 3 4 4 5 6 9 100)) - (test-case - "empty" - '() - '()) - (test-case - "singleton" - '(1) - '(1)) - (test-case - "two" - '(2 1) - '(1 2)) - (test-case - "reversed" - '(20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1) - '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)) - (test-case - "already sorted" - '(1 2 3 4 5 6 7 8 9 10) - '(1 2 3 4 5 6 7 8 9 10))))) - (for-each - (lambda (tc) - (let ((got (sort (lambda (x1 x2) (< x1 x2)) (xs tc)))) - (unless (equal? got (want tc)) - (errorf t "(sort {}) = {}, want {}." (xs tc) got (want tc))))) - tests))) +(test sort-ten-elem + (assert-equal + '(-2 0 2 3 4 4 5 6 9 100) + (sort < '(9 4 5 100 3 2 4 6 0 -2)))) + + +(test sort-empty + (assert-equal '() (sort < '()))) + + +(test sort-singleton + (assert-equal '(1) (sort < '(1)))) + + +(test sort-two + (assert-equal '(1 2) (sort < '(2 1)))) + + +(test sort-reversed + (assert-equal + '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20) + (sort < '(20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)))) + + +(test sort-already-sorted + (assert-equal + '(1 2 3 4 5 6 7 8 9 10) + (sort < '(1 2 3 4 5 6 7 8 9 10)))) diff --git a/strings-test.csc b/strings-test.csc index f7c8e53..4d7a751 100644 --- a/strings-test.csc +++ b/strings-test.csc @@ -1,103 +1,44 @@ (import (scheme base) (only (csc testing) - define-test - errorf - subtest) + assert + assert-equal + test) (csc strings)) -(define-test (test-str-prefix? t) - (define-record-type <test-case> - (test-case name prefix str want) - test-case? - (name name) - (prefix prefix) - (str str) - (want want)) - (let ((tests (list - (test-case - "good" - "asdf" - "asdfjkl;" - #t) - (test-case - "bad" - "asdf" - "asdbjkl;" - #f) - (test-case - "too long" - "asdf" - "as" - #f)))) - (for-each - (lambda (tc) - (subtest t (name tc) - (let ((got (str-prefix? (prefix tc) (str tc)))) - (unless (eq? got (want tc)) - (errorf t "(str-prefix? {} {}) = {}, want {}" (str-quote (prefix tc)) (str-quote (str tc)) got (want tc)))))) - tests))) +(test str-prefix?-good + (assert-equal #t (str-prefix? "asdf" "asdfjkl;"))) -(define-test (test-str-quote t) - (define-record-type <test-case> - (test-case name str want) - test-case? - (name name) - (str str) - (want want)) - (let ((tests (list - (test-case - "simple" - "hello" - "\"hello\"") - (test-case - "escape" - "this string \" has a quote" - "\"this string \\\" has a quote\"")))) - (for-each - (lambda (tc) - (subtest t (name tc) - (let ((got (str-quote (str tc)))) - (unless (equal? got (want tc)) - (errorf t "(str-quote {}) = {}, want {}" (str tc) (got tc) (want tc)))))) - tests))) +(test str-prefix?-bad + (assert-equal #f (str-prefix? "asdf" "asdbjkl;"))) -(define-test (test-str-find t) - (define-record-type <test-case> - (test-case name match str want) - test-case? - (name name) - (match match) - (str str) - (want want)) - (let ((tests (list - (test-case - "ok" - "abc" - "dabsadfdabcdfdfd" - 8) - (test-case - "one letter" - "a" - "sdfdfdfsasdfe" - 8)))) - (for-each - (lambda (tc) - (subtest t (name tc) - (let ((got (str-find (match tc) (str tc)))) - (unless (= got (want tc)) - (errorf t "(str-find {} {}) = {}, want {}" (str-quote (match tc)) (str-quote (str tc)) got (want tc)))))) - tests))) +(test str-prefix?-too-long + (assert-equal #f (str-prefix? "asdf" "as"))) -(define-test (test-str-find-notfound t) +(test str-quote-simple + (assert-equal "\"hello\"" (str-quote "hello"))) + + +(test str-quote-escape + (assert-equal "\"this string \\\" has a quote\"" (str-quote "this string \" has a quote"))) + + +(test str-find-ok + (assert-equal 8 (str-find "abc" "dabsadfdabcdfdfd"))) + + +(test str-find-one-letter + (assert-equal 8 (str-find "a" "sdfdfdfsasdfe"))) + + +(test test-str-find-notfound (let* ((match "a") (str "def") (got-exception '())) (guard (e ((str-not-found-error? e) (set! got-exception e))) (str-find match str)) - (unless (str-not-found-error? got-exception) - (errorf t "str-find succeeded, wanted <str-not-found-error>")))) + (assert (str-not-found-error? got-exception)))) diff --git a/testing.csc b/testing.csc index f221388..aebc574 100644 --- a/testing.csc +++ b/testing.csc @@ -1,19 +1,13 @@ (define-library (csc testing) (export - define-test - errorf - fatalf - test-main - subtest) + assert + assert-equal + test + test-main) (import (scheme base) (only (csc format) - printf - sprintf) - (only (csc vec) - vec - vec-append - vec-length - vec-ref)) + printf + sprintf)) (begin @@ -24,19 +18,9 @@ (define-record-type <test-handle> - (make-test-handle test-name subtest-name succeeded subtests-succeeded) + (make-test-handle test-name) test-handle? - (test-name base-test-name) - (subtest-name subtest-name) - (succeeded test-succeeded? set-succeeded!) - (subtests-succeeded subtests-succeeded set-subtests-succeeded!)) - - - (define (test-name t) - (let ((sn (subtest-name t))) - (if (equal? sn "") - (base-test-name t) - (sprintf "{}/{}" (base-test-name t) sn)))) + (test-name test-name set-name!)) (define-record-type <test-error> @@ -44,58 +28,41 @@ test-error?) - (define-syntax define-test + (define *test-handle* (make-test-handle "global")) + + + (define-syntax test (syntax-rules () - ((_ (name t) body ...) - (let ((t (make-test-handle (symbol->string 'name) "" #t (vec)))) - (printf "=== RUN {}\n" 'name) - (guard (e ((test-error? e)) - #;(else - (errorf t "{}" e))) - body ...) - (if (test-succeeded? t) - (printf "--- PASS: {}\n" 'name) - (begin - (printf "--- FAIL: {}\n" 'name) - (set-all-succeeded! #f))) - (do ((i 0 (+ 1 i))) - ((>= i (vec-length (subtests-succeeded t)))) - (printf " --- {}: {}/{}\n" - (if (cdr (vec-ref (subtests-succeeded t) i)) "PASS" "FAIL") - 'name - (car (vec-ref (subtests-succeeded t) i)))))))) + ((test name body body* ...) + (begin + (set-name! *test-handle* (symbol->string 'name)) + (printf "=== RUN {}\n" 'name) + (guard (e ((test-error? e) + (printf "--- FAIL: {}\n" 'name) + (set-all-succeeded! #f))) + body body* ... + (printf "--- PASS: {}\n" 'name)))))) - (define-syntax subtest - (syntax-rules () - ((_ t name body ...) - (let ((old-t t) - (t (make-test-handle (test-name t) name #t (vec)))) - (printf "=== RUN {}\n" (test-name t)) - (guard (e ((test-error? e)) - #;(else - (errorf t "{}" e))) - body ...) - (let ((succ (test-succeeded? t))) - (set-subtests-succeeded! old-t (vec-append (subtests-succeeded old-t) (cons name succ))) - (unless succ - (set-succeeded! old-t #f))))))) + (define (fatalf format-string . format-args) + (printf "{}: {}\n" (test-name *test-handle*) (apply sprintf format-string format-args)) + (raise (make-test-error))) - (define-syntax errorf + (define-syntax assert (syntax-rules () - ((_ t format-string format-args ...) - (begin - (set-succeeded! t #f) - (printf "{}: {}\n" (test-name t) (sprintf format-string format-args ...)))))) + ((assert expr) + (unless expr + (fatalf "Assertion {} failed." 'expr))))) - (define-syntax fatalf + (define-syntax assert-equal (syntax-rules () - ((_ t format-string format-args ...) - (begin - (errorf t format-string format-args ...) - (raise (make-test-error)))))) + ((assert-equal left right) + (let ((x left) + (y right)) + (unless (equal? x y) + (fatalf "Fatal: {} is not equal to {}.\nleft is {}\nright is {}" 'left 'right x y)))))) (define (test-main) diff --git a/vec-test.csc b/vec-test.csc index 681a7c0..8a19b3e 100644 --- a/vec-test.csc +++ b/vec-test.csc @@ -1,94 +1,33 @@ (import (scheme base) (only (csc testing) - subtest - define-test - errorf) + assert-equal + test) (csc vec)) -(define-test (test-vec t) - (define-record-type <test-case> - (test-case desc args want) - test-case? - (desc desc) - (args args) - (want want)) - (let ((tests (list - (test-case - "empty" - '() - '()) - (test-case - "singleton" - '(1) - '(1))))) - (for-each - (lambda (tc) - (subtest t (desc tc) - (let ((got (apply vec (args tc)))) - (unless (equal? (vec->list got) (want tc)) - (errorf t "(apply vec {}) = {}, want {}." (args tc) got (want tc))) - (unless (equal? (vec-length got) (length (want tc))) - (errorf t "(apply vec {}) length = {}, want {}." (args tc) (vec-length got) (length (want tc))))))) - tests))) +(test vec-empty + (assert-equal '() (vec->list (vec)))) -(define-test (test-vec-append t) - (define-record-type <test-case> - (test-case desc in arg want) - test-case? - (desc desc) - (in in) - (arg arg) - (want want)) - (let ((tests (list - (test-case - "append to empty" - '() - 1 - '(1)) - (test-case - "append to singleton" - '(1) - 2 - '(1 2)) - (test-case - "append to 2-elem" - '(1 2) - 3 - '(1 2 3))))) - (for-each - (lambda (tc) - (subtest t (desc tc) - (let* ((v (list->vec (in tc))) - (got (vec-append v (arg tc)))) - (unless (equal? (vec->list got) (want tc)) - (errorf t "(vec-append {} {}) = {}, want {}." v (arg tc) got (want tc)))))) - tests))) +(test vec-singleton + (assert-equal '(1) (vec->list (vec 1)))) -(define-test (test-vec-ref t) - (define-record-type <test-case> - (test-case desc xs k want) - test-case? - (desc desc) - (xs xs) - (k k) - (want want)) - (let ((tests (list - (test-case - "1" - '(1 2) - 1 - 2) - (test-case - "singleton" - '(1) - 0 - 1)))) - (for-each - (lambda (tc) - (let ((got (vec-ref (list->vec (xs tc)) (k tc)))) - (unless (= got (want tc)) - (errorf t "(vec-ref {} {}) = {}, want {}." (xs tc) (k tc) got (want tc))))) - tests))) +(test vec-append-to-empty + (assert-equal '(1) (vec->list (vec-append (vec) 1)))) + + +(test vec-append-to-singleton + (assert-equal '(1 2) (vec->list (vec-append (vec 1) 2)))) + + +(test vec-append-to-2-elem + (assert-equal '(1 2 3) (vec->list (vec-append (vec 1 2) 3)))) + + +(test vec-ref-1 + (assert-equal 2 (vec-ref (vec 1 2) 1))) + + +(test vec-ref-singleton + (assert-equal 1 (vec-ref (vec 1) 0))) |