80 lines
2.6 KiB
Scheme
80 lines
2.6 KiB
Scheme
|
;;;;
|
||
|
|
|
||
|
|
(import test)
|
||
|
|
|
||
|
|
#; ;FIXME
|
||
|
|
(import (chicken format) (test-utils gloss format) (test-utils gloss basic))
|
||
|
|
(import (chicken format) (test-utils gloss))
|
||
|
|
|
||
|
|
(import (test-utils run))
|
||
|
|
|
||
|
|
;Must set 1st thing
|
||
|
|
(runid 'EGG-NAME "test-utils")
|
||
|
|
|
||
|
|
;NOTE order
|
||
|
|
(define *tests* '("./test-utils-test.scm" "./three-test.scm" "./two-test.scm"))
|
||
|
|
|
||
|
|
(test-group "test-order<?"
|
||
|
|
(define +tst+ (reverse *tests*))
|
||
|
|
(define +len+ (length +tst+))
|
||
|
|
(define +mid+ (floor (/ +len+ 2)))
|
||
|
|
(define t<? (test-list-order< +tst+))
|
||
|
|
|
||
|
|
;same as (test-assert (<= 3 +len+))
|
||
|
|
(test-assert (< 0 +mid+ (sub1 +len+)))
|
||
|
|
|
||
|
|
(test-assert (t<? (list-ref +tst+ 0) (list-ref +tst+ (sub1 +len+))))
|
||
|
|
(test-assert (not (t<? (list-ref +tst+ (sub1 +len+)) (list-ref +tst+ 0))))
|
||
|
|
(test-assert (t<? (list-ref +tst+ 0) (list-ref +tst+ +mid+)))
|
||
|
|
(test-assert (not (t<? (list-ref +tst+ +mid+) (list-ref +tst+ 0))))
|
||
|
|
(test-assert (t<? (list-ref +tst+ +mid+) (list-ref +tst+ (sub1 +len+))))
|
||
|
|
(test-assert (not (t<? (list-ref +tst+ (sub1 +len+)) (list-ref +tst+ +mid+))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "runner"
|
||
|
|
(test "test-utils" (runid 'EGG-NAME))
|
||
|
|
(test "default dir" "." (runid '*test-directory*))
|
||
|
|
(test "default ext" "scm" (runid '*test-extension*))
|
||
|
|
(glossf "run-ident: ~S" (run-ident))
|
||
|
|
(test-group "level 1"
|
||
|
|
(define (empty-before id)
|
||
|
|
(test (string-append "empty " (symbol->string id)) '() (runid id)))
|
||
|
|
(gloss "level 1 (before 1st test)")
|
||
|
|
(for-each empty-before
|
||
|
|
'(*csi-options*
|
||
|
|
*csi-excl-options*
|
||
|
|
*csc-options*
|
||
|
|
*csc-excl-options*
|
||
|
|
*test-excl-names*))
|
||
|
|
(gloss "level 1 (after 1st test)")
|
||
|
|
(test "lexo test order" string<? (runid '*test-order*))
|
||
|
|
(test-group "level 2"
|
||
|
|
(gloss "level 2 (before 1st test)")
|
||
|
|
(test "expected test-lineup" *tests* (test-lineup))
|
||
|
|
(gloss "level 2 (after 1st test)")
|
||
|
|
)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "test order"
|
||
|
|
(define (myord a b)
|
||
|
|
(import (chicken pathname))
|
||
|
|
(test-assert "expected order arguments"
|
||
|
|
(and (not (pathname-directory a))
|
||
|
|
(equal? (pathname-directory a) (pathname-directory b))
|
||
|
|
(not (pathname-extension a))
|
||
|
|
(equal? (pathname-extension a) (pathname-extension b))))
|
||
|
|
(string<? a b) )
|
||
|
|
(test-assert "successful reset" (not (test-lineup #f)))
|
||
|
|
(test "change order" myord (runid '*test-order* myord))
|
||
|
|
(test "changed order" myord (runid '*test-order*))
|
||
|
|
(let ((res (test-lineup)))
|
||
|
|
(test "expected test-lineup" *tests* res) )
|
||
|
|
(test "reset order" string<? (runid '*test-order* string<?))
|
||
|
|
)
|
||
|
|
|
||
|
|
;quit when not ahead
|
||
|
|
(when (positive? (test-failure-count)) (test-exit))
|
||
|
|
(gloss "Hello 1, 3 & 2")
|
||
|
|
(run-tests)
|