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

fixed up these files to be friendlier to the dr dr

Browse Source 
svn: r16354
This commit is contained in:
Robby Findler 2009-10-17 21:23:35 +00:00
parent fd5f274c50
commit 931cb35fa4
6 changed files with 86 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/drscheme/README
View File

@ -40,7 +40,7 @@ the function, all tests will be run.
This tests the launcher feature of drscheme.
sample-solutions-one-window.ss
|# sample-solutions-one-window.ss #|
This tests the sample solutions in HtDP,
but reuses the same drscheme window.

8
collects/tests/drscheme/io.ss
View File

@ -182,11 +182,13 @@ add this test:
"ab\n"
"ab\n(97 #\"b\" #\"\\n\" #\"\\2\")"))
(define drs-frame (wait-for-drscheme-frame))
(define interactions-text (send drs-frame get-interactions-text))
(set-language-level! (list #rx"Pretty Big"))
(define drs-frame #f)
(define interactions-text #f)
(define (run-test)
(set! drs-frame (wait-for-drscheme-frame))
(set! interactions-text (send drs-frame get-interactions-text))
(set-language-level! (list #rx"Pretty Big"))
(output-err-port-checking) ;; must come first
;(long-io/execute-test)
(reading-test)

28
collects/tests/drscheme/module-lang-test-utils.ss
View File

@ -43,20 +43,23 @@
tests)))
(define temp-files '())
(define init-temp-files void)
(define (write-test-modules* name code)
(let ([file (build-path (this-expression-source-directory) (format "~a.ss" name))])
(set! temp-files (cons file temp-files))
(with-output-to-file file #:exists 'truncate
(lambda () (printf "~s\n" code)))))
(set! init-temp-files
(let ([old init-temp-files])
(λ ()
(let ([file (build-path (this-expression-source-directory) (format "~a.ss" name))])
(set! temp-files (cons file temp-files))
(with-output-to-file file #:exists 'truncate
(lambda () (printf "~s\n" code))))
(old)))))
(define-syntax write-test-modules
(syntax-rules (module)
[(_ (module name lang x ...) ...)
(begin (write-test-modules* 'name '(module name lang x ...)) ...)]))
(define drs (wait-for-drscheme-frame))
(define interactions-text (send drs get-interactions-text))
(define definitions-text (send drs get-definitions-text))
(define (single-test test)
(let/ec k
(clear-definitions drs)
@ -123,7 +126,16 @@
error-ranges-expected
(send interactions-text get-error-ranges))))])))))
(define drs 'not-yet-drs-frame)
(define interactions-text 'not-yet-interactions-text)
(define definitions-text 'not-yet-definitions-text)
(define (run-test)
(set! drs (wait-for-drscheme-frame))
(set! interactions-text (send drs get-interactions-text))
(set! definitions-text (send drs get-definitions-text))
(init-temp-files)
(run-use-compiled-file-paths-tests)

26
collects/tests/drscheme/module-lang-test.ss
View File

@ -2,32 +2,6 @@
(require "module-lang-test-utils.ss")
(provide run-test)
#;
(error #<<--
need to add tests cases that check the value of the use-compiled-file handler:
non-errortrace mode, saving compiled-files
> (list (build-path "compiled" "drscheme") (build-path "compiled"))
non-errortrace mode, not saving compiled files:
the default, eg (list (build-path "compiled"))
> >> errortrace mode, saving compiled files:
> >>
> >> (list (build-path "compiled" "drscheme" "errortrace")
> >> (build-path "compiled" "errortrace"))
> >>
> >> errortrace mode, not saving compiled files:
> >>
> >> (list (build-path "compiled" "errortrace"))
> >>
> >> And the two lists should also include (list (build-path
> >> "compiled")) at the end.
--
)
;; set up for tests that need external files
(write-test-modules
(module module-lang-test-tmp1 mzscheme

107
collects/tests/drscheme/sample-solutions-one-window.ss
View File

@ -18,67 +18,23 @@
[(section . <= . 29) '("How to Design Programs" "Intermediate Student with lambda")]
[else '("How to Design Programs" "Advanced Student")]))
(define sample-solutions-teachpack-filename
(build-path (collection-path "tests" "drscheme") "sample-solutions-testsuite-tp.scm"))
(define sample-solutions-dir
(let ([try1
(collection-path "solutions")]
[try2
(build-path (collection-path "mzlib")
'up
'up
'up
"robby"
"collects"
"solutions")])
(cond
[(directory-exists? try1) try1]
[else try2])))
(unless (directory-exists? sample-solutions-dir)
(error 'sample-solutions.ss "expected directory ~s to exist" sample-solutions-dir))
(set! sample-solutions-dir (normalize-path sample-solutions-dir))
(define toc (call-with-input-file (build-path sample-solutions-dir "toc.ss") read))
(define default-toc-entry '(#f ()))
(define labels
(let* ([all-info (call-with-input-file (build-path (collection-path "solutions")
'up 'up "proj" "book" "solutions"
"labels.scm") read)]
[ex-labels (filter (lambda (x) (and (string=? (substring (car x) 0 3) "ex:")
(> (string-length (car x)) 3)))
all-info)])
(map (lambda (x)
(cons (string-append (substring (car x) 3 (string-length (car x))) ".scm")
(cdr x)))
ex-labels)))
(define (filename->section filename)
(define (filename->section labels filename)
(let* ([label (car (memf (lambda (x) (string=? (car x) filename)) labels))]
[section (car (cadr label))])
section))
(define sample-solutions
(sort
(filter (lambda (x)
(and (> (string-length x) 3)
(string=? "scm" (substring x (- (string-length x) 3) (string-length x)))
(memf (lambda (y) (string=? (car y) x)) labels)))
(directory-list sample-solutions-dir))
(lambda (fx fy)
(< (filename->section fx) (filename->section fy)))))
(define separator-sexp "should be")
(define (test-single-file filename)
(let* ([toc-entry (let ([lookup (assoc (string->symbol filename) toc)])
(define ((test-single-file labels sample-solutions-dir toc) filename)
(let* ([sample-solutions-teachpack-filename
(build-path (collection-path "tests" "drscheme") "sample-solutions-testsuite-tp.scm")]
[toc-entry (let ([lookup (assoc (string->symbol filename) toc)])
(if lookup
(cdr lookup)
default-toc-entry))]
[section (filename->section filename)]
[section (filename->section labels filename)]
[language (section->language section)]
[errors-ok? (car toc-entry)]
[teachpacks (cadr toc-entry)])
@ -248,4 +204,53 @@
(zero? (send c blue))))
(define (run-test)
(for-each test-single-file sample-solutions)))
(define sample-solutions-dir
(let ([try1
(with-handlers ((exn:fail? (λ (x) #f)))
(collection-path "solutions"))]
[try2
(build-path (collection-path "mzlib")
'up
'up
'up
"robby"
"collects"
"solutions")])
(cond
[(and try1 (directory-exists? try1)) try1]
[else try2])))
(define stupid-internal-definitions-syntax
(unless (directory-exists? sample-solutions-dir)
(error 'sample-solutions.ss "expected directory ~s to exist" sample-solutions-dir)))
(define stupid-internal-definitions-syntax2
(set! sample-solutions-dir (normalize-path sample-solutions-dir)))
(define toc (call-with-input-file (build-path sample-solutions-dir "toc.ss") read))
(define labels
(let* ([all-info (call-with-input-file (build-path (collection-path "solutions")
'up 'up "proj" "book" "solutions"
"labels.scm") read)]
[ex-labels (filter (lambda (x) (and (string=? (substring (car x) 0 3) "ex:")
(> (string-length (car x)) 3)))
all-info)])
(map (lambda (x)
(cons (string-append (substring (car x) 3 (string-length (car x))) ".scm")
(cdr x)))
ex-labels)))
(define sample-solutions
(sort
(filter (lambda (x)
(and (> (string-length x) 3)
(string=? "scm" (substring x (- (string-length x) 3) (string-length x)))
(memf (lambda (y) (string=? (car y) x)) labels)))
(directory-list sample-solutions-dir))
(lambda (fx fy)
(< (filename->section labels fx) (filename->section labels fy)))))
(for-each (test-single-file labels sample-solutions-dir toc) sample-solutions)))

6
collects/tests/drscheme/teachpack.ss
View File

@ -9,8 +9,8 @@
(provide run-test)
(define drs-frame (wait-for-drscheme-frame))
(define interactions-text (send drs-frame get-interactions-text))
(define drs-frame 'not-yet-drs-frame)
(define interactions-text 'not-yet-interactions-text)
(define good-teachpack-name "teachpack-tmp~a")
@ -233,6 +233,8 @@
[else #f])))
(define (run-test)
(set! drs-frame (wait-for-drscheme-frame))
(set! interactions-text (send drs-frame get-interactions-text))
;(good-tests)
;(bad-tests)
(test-built-in-teachpacks)))