From 931cb35fa44408786d8920fba20907c5191bb254 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 17 Oct 2009 21:23:35 +0000 Subject: [PATCH] fixed up these files to be friendlier to the dr dr svn: r16354 --- collects/tests/drscheme/README | 2 +- collects/tests/drscheme/io.ss | 8 +- .../tests/drscheme/module-lang-test-utils.ss | 28 +++-- collects/tests/drscheme/module-lang-test.ss | 26 ----- .../drscheme/sample-solutions-one-window.ss | 107 +++++++++--------- collects/tests/drscheme/teachpack.ss | 6 +- 6 files changed, 86 insertions(+), 91 deletions(-) diff --git a/collects/tests/drscheme/README b/collects/tests/drscheme/README index 0e80e28e43..6b7ff39f55 100644 --- a/collects/tests/drscheme/README +++ b/collects/tests/drscheme/README @@ -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. diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss index 195ff8922c..083158c872 100644 --- a/collects/tests/drscheme/io.ss +++ b/collects/tests/drscheme/io.ss @@ -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) diff --git a/collects/tests/drscheme/module-lang-test-utils.ss b/collects/tests/drscheme/module-lang-test-utils.ss index af2505bebc..bc16fc483b 100644 --- a/collects/tests/drscheme/module-lang-test-utils.ss +++ b/collects/tests/drscheme/module-lang-test-utils.ss @@ -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) diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss index cd6a4e57b4..ad5dd5a63c 100644 --- a/collects/tests/drscheme/module-lang-test.ss +++ b/collects/tests/drscheme/module-lang-test.ss @@ -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 diff --git a/collects/tests/drscheme/sample-solutions-one-window.ss b/collects/tests/drscheme/sample-solutions-one-window.ss index 306a119b29..19aebc9283 100644 --- a/collects/tests/drscheme/sample-solutions-one-window.ss +++ b/collects/tests/drscheme/sample-solutions-one-window.ss @@ -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))) diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss index c570812e7f..ec44902473 100644 --- a/collects/tests/drscheme/teachpack.ss +++ b/collects/tests/drscheme/teachpack.ss @@ -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)))