suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rewrote schemeunit test

Browse Source 
svn: r18271
This commit is contained in:
Ryan Culpepper 2010-02-22 21:12:11 +00:00
parent 11b8fd4204
commit d4b0f917df
1 changed files with 6 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/tests/xml/test-clark.ss
View File

@ -1,13 +1,8 @@
#lang scheme #lang scheme
(require schemeunit (require schemeunit
schemeunit/private/check
schemeunit/private/test-case
schemeunit/private/test-suite
schemeunit/text-ui schemeunit/text-ui
xml xml
scheme/runtime-path) scheme/runtime-path)
(require/expose schemeunit/private/test-suite
(current-seed))
(define (validate-xml? xml) (define (validate-xml? xml)
(error 'validate-xml? "Not implemented")) (error 'validate-xml? "Not implemented"))
@ -17,26 +12,14 @@
(define (read-xml/file f) (define (read-xml/file f)
(with-input-from-file f (with-input-from-file f
(lambda () (read-xml)))) (lambda () (read-xml))))
(define (dir->test-suite d name path->test-case) (define (dir->test-suite d name path->test-case)
(make-schemeunit-test-suite (test-suite
name name
(lambda (fdown fup fhere seed) (for ([p (directory-list d)]
(parameterize #:when (let ([ext (filename-extension p)])
([current-seed seed] (and ext (bytes=? #"xml" ext))))
[current-test-case-around (test-suite-test-case-around fhere)] (path->test-case (build-path d p)))))
[current-check-around (test-suite-check-around fhere)])
(for-each (lambda (p)
(define t (path->test-case (build-path d p)))
(if (schemeunit-test-suite? t)
(current-seed (apply-test-suite t fdown fup fhere (current-seed)))
t))
(filter (lambda (p)
(define ext (filename-extension p))
(and ext (bytes=? #"xml" ext)))
(directory-list d))))
(current-seed))
void
void))
(define (not-wf-dir->test-suite d) (define (not-wf-dir->test-suite d)
(define (path->test-case f) (define (path->test-case f)