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

drdr-ized the rest of the drscheme test suite

Browse Source 
svn: r17945
This commit is contained in:
Robby Findler 2010-02-02 21:06:07 +00:00
parent 8d2f32efed
commit e74e46d9ca
11 changed files with 587 additions and 807 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/mrlib/text-string-style-desc.ss
View File

@ -1,20 +1,19 @@
(module text-string-style-desc mzscheme #lang scheme/base
(provide get-string/style-desc)
(require mred
mzlib/etc
mzlib/class)
;; get-string/style-desc : text -> (listof str/ann) (provide get-string/style-desc)
(define get-string/style-desc (require scheme/gui/base
(opt-lambda (text [start 0] [end (send text last-position)]) scheme/class)
;; get-string/style-desc : text -> (listof str/ann)
(define (get-string/style-desc text [start 0] [end (send text last-position)])
(let* ([snips (get-snips text start end)] (let* ([snips (get-snips text start end)]
[str/ann (map snip->str/ann snips)] [str/ann (map snip->str/ann snips)]
[joined-str/ann (join-like str/ann)]) [joined-str/ann (join-like str/ann)])
joined-str/ann))) joined-str/ann))
;; get-snips : text -> (listof snip) ;; get-snips : text -> (listof snip)
;; extracts the snips from a text ;; extracts the snips from a text
(define (get-snips text start end) (define (get-snips text start end)
(send text split-snip start) (send text split-snip start)
(send text split-snip end) (send text split-snip end)
(let loop ([snip (send text find-snip start 'after-or-none)]) (let loop ([snip (send text find-snip start 'after-or-none)])
@ -24,9 +23,9 @@
(cons snip (loop (send snip next)))] (cons snip (loop (send snip next)))]
[else null]))) [else null])))
;; snip->str/ann : snip -> str/ann ;; snip->str/ann : snip -> str/ann
;; extracts the style type from the snip ;; extracts the style type from the snip
(define (snip->str/ann snip) (define (snip->str/ann snip)
(let* ([str (cond (let* ([str (cond
[(is-a? snip string-snip%) [(is-a? snip string-snip%)
(send snip get-text 0 (send snip get-count))] (send snip get-text 0 (send snip get-count))]
@ -40,8 +39,8 @@
(describe-style style))]) (describe-style style))])
(list str style-desc))) (list str style-desc)))
;; describe-style : style -> (listof symbol) ;; describe-style : style -> (listof symbol)
(define (describe-style style) (define (describe-style style)
(list (list
'alignment (send style get-alignment) 'alignment (send style get-alignment)
'background (symbolic-color (send style get-background)) 'background (symbolic-color (send style get-background))
@ -51,25 +50,25 @@
'size (send style get-size) 'size (send style get-size)
'underlined (send style get-underlined))) 'underlined (send style get-underlined)))
(define (symbolic-color color) (define (symbolic-color color)
(list (send color red) (list (send color red)
(send color green) (send color green)
(send color blue))) (send color blue)))
;; translate-name : (union #f string) -> symbol ;; translate-name : (union #f string) -> symbol
;; translates the style name to a symbol ;; translates the style name to a symbol
(define (translate-name str) (define (translate-name str)
(and str (and str
(let ([m (regexp-match re:translate-name str)]) (let ([m (regexp-match re:translate-name str)])
(and m (and m
(string->symbol (cadr m)))))) (string->symbol (cadr m))))))
;; re:translate-name : regexp ;; re:translate-name : regexp
(define re:translate-name (regexp "^.*:([^:]*)$")) (define re:translate-name (regexp "^.*:([^:]*)$"))
;; join-like : (listof str/ann) -> (listof str/ann) ;; join-like : (listof str/ann) -> (listof str/ann)
;; joins same styles to form largest groups ;; joins same styles to form largest groups
(define (join-like str/anns) (define (join-like str/anns)
(cond (cond
[(null? str/anns) null] [(null? str/anns) null]
[else [else
@ -87,4 +86,4 @@
(cdr rest)) (cdr rest))
(cons first (cons first
(loop second (loop second
(cdr rest)))))]))]))) (cdr rest)))))]))]))

55
collects/tests/drscheme/README.ss
View File

@ -1,55 +0,0 @@
#lang scheme/base
(provide all-tests)
(define all-tests (map symbol->string '(
#|
This directory contains code for testing DrScheme. To run the tests,
load run-test.ss. It will return a function that accepts the names of
tests. Those names must be listed here. If no arguments are passed to
the function, all tests will be run.
stepper-test.ss
runs the stepper on the sample solutions and
checks the results.
(this test suite is not being maintained)
|# io.ss #|
This tests the drscheme's io implementation.
|# repl-test.ss #|
This tests various interactions between parameters in the
implementation of drscheme.
|# language-test.ss #|
This tests that all of the individual settings in the language dialog
take effect in the repl.
|# module-lang-test.ss #|
This tests the code involved in implementing the new module language.
graphics.ss
This tests the various graphic elements that can appear
in programs.
launcher.ss
This tests the launcher feature of drscheme.
|# sample-solutions-one-window.ss #|
This tests the sample solutions in HtDP,
but reuses the same drscheme window.
There is a race condition in this test,
so it is commented out here, for now.
|# teachpack.ss #|
Tests the teachpacks
|#)))

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

@ -1,3 +1,5 @@
#lang scheme/base
#| #|
add this test: add this test:
@ -10,21 +12,14 @@ add this test:
|# |#
(module io mzscheme (require "drscheme-test-util.ss"
(require "drscheme-test-util.ss"
tests/utils/gui tests/utils/gui
mzlib/class mzlib/class
mzlib/list
mzlib/pretty mzlib/pretty
mred mred
framework mrlib/text-string-style-desc)
mrlib/text-string-style-desc
(prefix fw: framework))
(provide run-test) (define (check-output expression expected)
(define (output-err-port-checking)
(define (check-output expression expected)
(begin (begin
(clear-definitions drs-frame) (clear-definitions drs-frame)
(type-in-definitions drs-frame expression) (type-in-definitions drs-frame expression)
@ -40,12 +35,12 @@ add this test:
expected expected
got)) got))
(fprintf (current-error-port) (fprintf (current-error-port)
"expected ~s, got ~s for ~s\n\n" "expected ~s\n got ~s\nfor ~s\n\n"
expected expected
got got
expression))))) expression)))))
(define (get-annotated-output) (define (get-annotated-output)
(let ([chan (make-channel)]) (let ([chan (make-channel)])
(queue-callback (queue-callback
(λ () (λ ()
@ -55,16 +50,18 @@ add this test:
(send text paragraph-start-position 2)))))) (send text paragraph-start-position 2))))))
(channel-get chan))) (channel-get chan)))
(define (output-style x) (eq? x '|ports out|))
(define (error-style x) (eq? x '|ports err|))
(define (value-style x) (eq? x '|ports value|))
(define prompt '("\n> " default-color)) (define (output-style x) (eq? x '|ports out|))
(define (error-style x) (eq? x '|ports err|))
(define (value-style x) (eq? x '|ports value|))
(define prompt '("\n> " default-color))
(define (output-err-port-checking)
;; this test has to be first to test an uninitialized state of the port ;; this test has to be first to test an uninitialized state of the port
(check-output "(port-next-location (current-input-port))" (check-output "(port-next-location (current-input-port))"
(list `("1\n0\n1" |ports value|) (list `("1\n0\n1\n" |ports value|)
prompt)) '("> " default-color)))
(check-output "(display 1)" (list (list "1" output-style) prompt)) (check-output "(display 1)" (list (list "1" output-style) prompt))
(check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt)) (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt))
@ -100,7 +97,7 @@ add this test:
(list (list "1" error-style) (list (list "1" error-style)
prompt))) prompt)))
(define (long-io/execute-test) (define (long-io/execute-test)
(let ([string-port (open-output-string)]) (let ([string-port (open-output-string)])
(pretty-print (pretty-print
(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p))))) (let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))
@ -121,7 +118,7 @@ add this test:
(error 'io.ss "failed long io / execute test (output doesn't match)"))))) (error 'io.ss "failed long io / execute test (output doesn't match)")))))
(define (reading-test) (define (reading-test)
(define (do-input-test program input expected-transcript) (define (do-input-test program input expected-transcript)
(do-execute drs-frame) (do-execute drs-frame)
(type-in-interactions drs-frame program) (type-in-interactions drs-frame program)
@ -140,7 +137,8 @@ add this test:
(send interactions-text paragraph-end-position (send interactions-text paragraph-end-position
(- (send interactions-text last-paragraph) 1)))]) (- (send interactions-text last-paragraph) 1)))])
(unless (equal? got-value expected-transcript) (unless (equal? got-value expected-transcript)
(printf "FAILED: expected: ~s~n got: ~s~n program: ~s~n input: ~s~n" (fprintf (current-error-port)
"FAILED: expected: ~s~n got: ~s~n program: ~s~n input: ~s~n"
expected-transcript got-value program input))))) expected-transcript got-value program input)))))
(clear-definitions drs-frame) (clear-definitions drs-frame)
@ -156,7 +154,7 @@ add this test:
(do-input-test "(begin (read-char) (sleep 1) (read-char))" "ab\ncd\n" "ab\ncd\n#\\b") (do-input-test "(begin (read-char) (sleep 1) (read-char))" "ab\ncd\n" "ab\ncd\n#\\b")
(do-input-test "(list (read) (sleep 1) (read) (read))" "a b\nc d\n" "a b\nc d\n(a #<void> b c)") (do-input-test "(list (read) (sleep 1) (read) (read))" "a b\nc d\n" "a b\nc d\n(a #<void> b c)")
(do-input-test "(begin (display 1) (read))" "2\n" "12\n2\n") ;; why an extra newline?! (do-input-test "(begin (display 1) (read))" "2\n" "12\n2")
(do-input-test "(read-line)" "\n" "\n\"\"") (do-input-test "(read-line)" "\n" "\n\"\"")
(do-input-test "(read-char)" "\n" "\n#\\newline") (do-input-test "(read-char)" "\n" "\n#\\newline")
@ -169,7 +167,7 @@ add this test:
"()\n" "()\n"
"()\n()") "()\n()")
(do-input-test "(begin (write (read)) (write (read)))" (do-input-test "(begin (write (read)) (flush-output) (write (read)))"
"(1)\n(2)\n" "(1)\n(2)\n"
"(1)\n(1)(2)\n(2)") "(1)\n(1)(2)\n(2)")
@ -182,14 +180,23 @@ add this test:
"ab\n" "ab\n"
"ab\n(97 #\"b\" #\"\\n\" #\"\\2\")")) "ab\n(97 #\"b\" #\"\\n\" #\"\\2\")"))
(define drs-frame #f) (define drs-frame #f)
(define interactions-text #f) (define interactions-text #f)
(define (run-test) (let ([s (make-semaphore)])
(fire-up-drscheme)
(thread
(λ ()
(set! drs-frame (wait-for-drscheme-frame)) (set! drs-frame (wait-for-drscheme-frame))
(set! interactions-text (send drs-frame get-interactions-text)) (set! interactions-text (send drs-frame get-interactions-text))
(set-language-level! (list #rx"Pretty Big")) (set-language-level! (list #rx"Pretty Big"))
(clear-definitions drs-frame)
(do-execute drs-frame)
(output-err-port-checking) ;; must come first (output-err-port-checking) ;; must come first
;(long-io/execute-test) ;(long-io/execute-test)
(reading-test) (reading-test)
)) (semaphore-post s)))
(yield s)
(exit))

22
collects/tests/drscheme/language-test.ss
View File

@ -20,8 +20,6 @@ the settings above should match r5rs
framework framework
(prefix-in fw: framework)) (prefix-in fw: framework))
(provide run-test)
(define language (make-parameter "<<not a language>>")) (define language (make-parameter "<<not a language>>"))
;; set-language : boolean -> void ;; set-language : boolean -> void
@ -1045,7 +1043,8 @@ the settings above should match r5rs
(do-execute drs) (do-execute drs)
(let* ([got (fetch-output/should-be-tested drs)]) (let* ([got (fetch-output/should-be-tested drs)])
(unless (string=? result got) (unless (string=? result got)
(printf "FAILED: ~s ~s ~s test~n expected: ~s~n got: ~s~n" (fprintf (current-error-port)
"FAILED: ~s ~s ~s test~n expected: ~s~n got: ~s~n"
(language) setting-name expression result got))))) (language) setting-name expression result got)))))
(define (test-hash-bang) (define (test-hash-bang)
@ -1058,7 +1057,8 @@ the settings above should match r5rs
(do-execute drs) (do-execute drs)
(let* ([got (fetch-output/should-be-tested drs)]) (let* ([got (fetch-output/should-be-tested drs)])
(unless (string=? "1" got) (unless (string=? "1" got)
(printf "FAILED: ~s ~a test~n expected: ~s~n got: ~s~n" (fprintf (current-error-port)
"FAILED: ~s ~a test~n expected: ~s~n got: ~s~n"
(language) expression result got))))) (language) expression result got)))))
(define (fetch-output/should-be-tested . args) (define (fetch-output/should-be-tested . args)
@ -1094,7 +1094,8 @@ the settings above should match r5rs
(min (string-length line1-expect) (min (string-length line1-expect)
(string-length line1-got)))) (string-length line1-got))))
(regexp-match line1-expect line1-got))) (regexp-match line1-expect line1-got)))
(printf "expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n" (fprintf (current-error-port)
"expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n"
line0-expect line1-expect line0-expect line1-expect
line0-got line1-got) line0-got line1-got)
(error 'language-test.ss "failed get top of repl test"))))) (error 'language-test.ss "failed get top of repl test")))))
@ -1176,7 +1177,8 @@ the settings above should match r5rs
(unless (if (procedure? answer) (unless (if (procedure? answer)
(answer got) (answer got)
(whitespace-string=? answer got)) (whitespace-string=? answer got))
(printf "FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n" (fprintf (current-error-port)
"FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n"
(language) option show-sharing pretty? (language) option show-sharing pretty?
(shorten got) (shorten got)
(if (procedure? answer) (answer) answer)))))]) (if (procedure? answer) (answer) answer)))))])
@ -1244,7 +1246,8 @@ the settings above should match r5rs
(send interactions-text paragraph-end-position (send interactions-text paragraph-end-position
(- (send interactions-text last-paragraph) 1)))]) (- (send interactions-text last-paragraph) 1)))])
(unless (equal? got "0") (unless (equal? got "0")
(printf "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got)))))) (fprintf (current-error-port)
"FAILED: test-error-after-definition failed, expected 0, got ~s\n" got))))))
;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image))) ;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image)))
@ -1348,3 +1351,8 @@ the settings above should match r5rs
(go advanced) (go advanced)
(go pretty-big) (go pretty-big)
(go r5rs)) (go r5rs))
(let ()
(fire-up-drscheme)
(thread (λ () (run-test) (exit)))
(yield (make-semaphore)))

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

@ -75,7 +75,8 @@
(send interactions-text paragraph-start-position 2) (send interactions-text paragraph-start-position 2)
(send interactions-text paragraph-end-position 2))]) (send interactions-text paragraph-end-position 2))])
(unless (or (test-all? test) (string=? "> " after-execute-output)) (unless (or (test-all? test) (string=? "> " after-execute-output))
(printf "FAILED (line ~a): ~a\n ~a\n expected no output after execution, got: ~s\n" (fprintf (current-error-port)
"FAILED (line ~a): ~a\n ~a\n expected no output after execution, got: ~s\n"
(test-line test) (test-line test)
(test-definitions test) (test-definitions test)
(or (test-interactions test) 'no-interactions) (or (test-interactions test) 'no-interactions)
@ -107,7 +108,8 @@
[else 'module-lang-test "bad test value: ~e" r]) [else 'module-lang-test "bad test value: ~e" r])
r text))]) r text))])
(unless output-passed? (unless output-passed?
(printf "FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n" (fprintf (current-error-port)
"FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n"
(test-line test) (test-line test)
(test-definitions test) (test-definitions test)
(or (test-interactions test) 'no-interactions) (or (test-interactions test) 'no-interactions)
@ -120,7 +122,8 @@
(let ([error-ranges-expected (let ([error-ranges-expected
((test-error-ranges test) definitions-text interactions-text)]) ((test-error-ranges test) definitions-text interactions-text)])
(unless (equal? error-ranges-expected (send interactions-text get-error-ranges)) (unless (equal? error-ranges-expected (send interactions-text get-error-ranges))
(printf "FAILED (line ~a; ranges): ~a\n expected: ~s\n got: ~s\n" (fprintf (current-error-port)
"FAILED (line ~a; ranges): ~a\n expected: ~s\n got: ~s\n"
(test-line test) (test-line test)
(test-definitions test) (test-definitions test)
error-ranges-expected error-ranges-expected

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

@ -262,3 +262,10 @@
(current-namespace (make-base-empty-namespace))} (current-namespace (make-base-empty-namespace))}
"(+ 1 2)" "(+ 1 2)"
"3") "3")
(require "drscheme-test-util.ss")
(let ()
(fire-up-drscheme)
(thread (λ () (run-test) (exit)))
(yield (make-semaphore 0)))

30
collects/tests/drscheme/repl-test.ss
View File

@ -17,8 +17,6 @@ This produces an ACK message
mred mred
framework) framework)
(provide run-test)
(define-struct loc (line col offset)) (define-struct loc (line col offset))
;; loc = (make-loc number number number) ;; loc = (make-loc number number number)
;; all numbers in loc structs start at zero. ;; all numbers in loc structs start at zero.
@ -1186,11 +1184,13 @@ This produces an ACK message
(cond (cond
[(eq? source-location 'definitions) [(eq? source-location 'definitions)
(unless (send definitions-canvas has-focus?) (unless (send definitions-canvas has-focus?)
(printf "FAILED execute test for ~s\n expected definitions to have the focus\n" (fprintf (current-error-port)
"FAILED execute test for ~s\n expected definitions to have the focus\n"
program))] program))]
[(eq? source-location 'interactions) [(eq? source-location 'interactions)
(unless (send interactions-canvas has-focus?) (unless (send interactions-canvas has-focus?)
(printf "FAILED execute test for ~s\n expected interactions to have the focus\n" (fprintf (current-error-port)
"FAILED execute test for ~s\n expected interactions to have the focus\n"
program))] program))]
[(send definitions-canvas has-focus?) [(send definitions-canvas has-focus?)
(let ([start (car source-location)] (let ([start (car source-location)]
@ -1203,7 +1203,8 @@ This produces an ACK message
(= (+ (srcloc-position error-range) -1) (loc-offset start)) (= (+ (srcloc-position error-range) -1) (loc-offset start))
(= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) (= (+ (srcloc-position error-range) -1 (srcloc-span error-range))
(loc-offset finish))) (loc-offset finish)))
(printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n" (fprintf (current-error-port)
"FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
program program
(and error-range (and error-range
(list (+ (srcloc-position error-range) -1) (list (+ (srcloc-position error-range) -1)
@ -1220,7 +1221,8 @@ This produces an ACK message
(regexp-match execute-answer received-execute)] (regexp-match execute-answer received-execute)]
[else #f]) [else #f])
(failure) (failure)
(printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n" (fprintf (current-error-port)
"FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
program program
language-cust language-cust
execute-answer received-execute)) execute-answer received-execute))
@ -1274,7 +1276,8 @@ This produces an ACK message
(regexp-match load-answer received-load)] (regexp-match load-answer received-load)]
[else #f]) [else #f])
(failure) (failure)
(printf "FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n" (fprintf (current-error-port)
"FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n"
short-filename short-filename
program load-answer received-load)))))]) program load-answer received-load)))))])
(load-test tmp-load-short-filename (make-load-answer in-vector language-cust #f)) (load-test tmp-load-short-filename (make-load-answer in-vector language-cust #f))
@ -1287,7 +1290,7 @@ This produces an ACK message
; check for edit-sequence ; check for edit-sequence
(when (repl-in-edit-sequence?) (when (repl-in-edit-sequence?)
(printf "FAILED: repl in edit-sequence") (fprintf (current-error-port) "FAILED: repl in edit-sequence")
(escape))))) (escape)))))
(define tests 0) (define tests 0)
@ -1298,7 +1301,7 @@ This produces an ACK message
(define (final-report) (define (final-report)
(if (= 0 failures) (if (= 0 failures)
(printf "tests finished: all ~a tests passed\n" tests) (printf "tests finished: all ~a tests passed\n" tests)
(printf "tests finished: ~a failed out of ~a total\n" failures tests))) (fprintf (current-error-port) "tests finished: ~a failed out of ~a total\n" failures tests)))
(define (run-test-in-language-level language-cust) (define (run-test-in-language-level language-cust)
(let ([level (list #rx"Pretty Big")]) (let ([level (list #rx"Pretty Big")])
@ -1470,8 +1473,7 @@ This produces an ACK message
(kill-tests) (kill-tests)
(callcc-test) (callcc-test)
(top-interaction-test) (top-interaction-test)
(final-report) (final-report))
)
(define (insert-in-definitions/newlines drs str) (define (insert-in-definitions/newlines drs str)
(let loop ([strs (regexp-split #rx"\n" str)]) (let loop ([strs (regexp-split #rx"\n" str)])
@ -1504,3 +1506,9 @@ This produces an ACK message
(if (regexp? b) (if (regexp? b)
(regexp (string-append (regexp-quote a) (object-name b))) (regexp (string-append (regexp-quote a) (object-name b)))
(string-append a b))) (string-append a b)))
(let ()
(fire-up-drscheme)
(thread (λ () (run-test) (exit)))
(yield (make-semaphore 0)))

143
collects/tests/drscheme/run-tests.ss
View File

@ -1,143 +0,0 @@
;; load this file as a tool to run the test suites
#lang scheme/base
(require scheme/class
scheme/gui/base
framework
"README.ss")
(provide ask-test-suite run-test-suite)
(define test-thread
(let ([kill-old void])
(lambda (test thunk)
(kill-old)
(let ([thread-desc (thread
(lambda ()
(printf "t>> ~a started~n" test)
(thunk)
(printf "t>> ~a finished~n" test)))])
(set! kill-old
(lambda ()
(when (thread-running? thread-desc)
(kill-thread thread-desc)
(printf "t>> killed ~a~n" test))))))))
(define (make-repl)
(test-thread
"REPL"
(lambda ()
(let ([startup "~/.mzschemerc"])
(when (file-exists? startup)
(load startup)))
(case (system-type)
[(windows macos)
(graphical-read-eval-print-loop (current-eventspace))]
[else
(read-eval-print-loop)]))))
(define (run-test-suite filename [die-afterwards? #f])
(test-thread
filename
(lambda ()
((dynamic-require `(lib ,filename "tests" "drscheme") 'run-test))
(when die-afterwards? (exit)))))
(define current-test-suite-frame #f)
(define test-suite-frame%
(class frame%
(define/override (on-size w h)
(preferences:set 'drscheme:test-suite:frame-width w)
(preferences:set 'drscheme:test-suite:frame-height h))
(define/augment (on-close)
(inner (void) on-close)
(set! current-test-suite-frame #f))
(super-new)))
(define (ask-test-suite parent)
(if current-test-suite-frame
(send current-test-suite-frame show #t)
(let* ([drscheme-test-dir (collection-path "tests" "drscheme")]
[frame (make-object test-suite-frame%
"Test Suites"
parent
(preferences:get 'drscheme:test-suite:frame-width)
(preferences:get 'drscheme:test-suite:frame-height))]
[panel (make-object vertical-panel% frame)]
[top-panel (make-object vertical-panel% panel)]
[bottom-panel (make-object horizontal-panel% panel)])
(send top-panel stretchable-height #f)
(make-object button%
"REPL"
bottom-panel
(lambda (_1 _2)
(send frame show #f)
(make-repl)))
(when drscheme-test-dir
(send top-panel stretchable-height #t)
(send bottom-panel stretchable-height #f)
(letrec ([lb (make-object list-box%
#f
all-tests
top-panel
(lambda (b e)
(when (eq? (send e get-event-type) 'list-box-dclick)
(run-test-suite-callback))))]
[run-test-suite-callback
(lambda ()
(let ([selection (send lb get-selection)])
(when selection
(send frame show #f)
(let ([test (list-ref all-tests selection)])
(preferences:set
'drscheme:test-suite:file-name
test)
(run-test-suite test)))))])
;; set values from preferences
(let* ([test-suite (preferences:get 'drscheme:test-suite:file-name)]
[num (send lb find-string test-suite)])
(when num
(send lb set-string-selection test-suite)
(send lb set-first-visible-item num)
(test:run-interval (preferences:get 'drscheme:test-suite:run-interval))))
(send
(make-object button%
"Run Test Suite"
bottom-panel
(lambda (_1 _2)
(run-test-suite-callback))
'(border))
focus))
(let* ([pre-times (list 0 10 50 100 500)]
[times (if (member (test:run-interval) pre-times)
pre-times
(append pre-times (list (test:run-interval))))]
[choice
(make-object choice%
"Run Interval"
(map number->string times)
top-panel
(lambda (choice event)
(let ([time (list-ref times (send choice get-selection))])
(preferences:set 'drscheme:test-suite:run-interval time)
(test:run-interval time))))])
(send choice set-selection
(let loop ([l times]
[n 0])
(if (= (car l) (test:run-interval))
n
(loop (cdr l)
(+ n 1)))))))
(make-object button%
"Cancel"
bottom-panel
(lambda (_1 _2)
(send frame show #f)))
(make-object grow-box-spacer-pane% bottom-panel)
(send frame show #t)
(set! current-test-suite-frame frame))))

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

@ -1,20 +1,19 @@
#lang scheme/base
(module teachpack mzscheme (require "drscheme-test-util.ss"
(require "drscheme-test-util.ss" scheme/class
mzlib/class scheme/path
mzlib/file scheme/gui/base
mred (prefix-in fw: framework))
framework
(prefix fw: framework))
(provide run-test) (provide run-test)
(define drs-frame 'not-yet-drs-frame) (define drs-frame 'not-yet-drs-frame)
(define interactions-text 'not-yet-interactions-text) (define interactions-text 'not-yet-interactions-text)
(define good-teachpack-name "teachpack-tmp~a") (define good-teachpack-name "teachpack-tmp~a")
(define (test-good-teachpack tp-exps dr-exp expected) (define (test-good-teachpack tp-exps dr-exp expected)
(clear-definitions drs-frame) (clear-definitions drs-frame)
(type-in-definitions drs-frame dr-exp) (type-in-definitions drs-frame dr-exp)
(fw:test:menu-select "Language" "Clear All Teachpacks") (fw:test:menu-select "Language" "Clear All Teachpacks")
@ -58,8 +57,8 @@
full-expectation full-expectation
got))))) got)))))
;; there are no more errors when the teachpack is loaded (for now...) ;; there are no more errors when the teachpack is loaded (for now...)
(define (test-bad/load-teachpack tp-exp expected-error) (define (test-bad/load-teachpack tp-exp expected-error)
(fw:test:menu-select "Language" "Clear All Teachpacks") (fw:test:menu-select "Language" "Clear All Teachpacks")
(let ([tp-name (normal-case-path (let ([tp-name (normal-case-path
(normalize-path (normalize-path
@ -89,7 +88,7 @@
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" (printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n"
tp-exp expected-error)])))) tp-exp expected-error)]))))
(define (test-bad/execute-teachpack tp-exp expected) (define (test-bad/execute-teachpack tp-exp expected)
(fw:test:menu-select "Language" "Clear All Teachpacks") (fw:test:menu-select "Language" "Clear All Teachpacks")
(let ([tp-name (normal-case-path (let ([tp-name (normal-case-path
(normalize-path (normalize-path
@ -134,7 +133,7 @@
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" (printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n"
tp-exp error)])))) tp-exp error)]))))
(define (generic-tests) (define (generic-tests)
(test-good-teachpack (test-good-teachpack
(list (list
`(module ,(string->symbol (format good-teachpack-name 0)) mzscheme)) `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme))
@ -158,12 +157,12 @@
"(+ not-a-primitive1 not-a-primitive2)" "(+ not-a-primitive1 not-a-primitive2)"
"3")) "3"))
(define (good-tests) (define (good-tests)
(set-language-level! '("How to Design Programs" "Beginning Student")) (set-language-level! '("How to Design Programs" "Beginning Student"))
(do-execute drs-frame) (do-execute drs-frame)
(generic-tests)) (generic-tests))
(define (bad-tests) (define (bad-tests)
(set-language-level! '("How to Design Programs" "Beginning Student")) (set-language-level! '("How to Design Programs" "Beginning Student"))
(test-bad/execute-teachpack (test-bad/execute-teachpack
@ -174,7 +173,7 @@
`(module teachpack-tmp mzscheme (car)) `(module teachpack-tmp mzscheme (car))
"car: expects argument of type <pair>; given 1")) "car: expects argument of type <pair>; given 1"))
(define (get-string-from-file fn) (define (get-string-from-file fn)
(call-with-input-file fn (call-with-input-file fn
(lambda (port) (lambda (port)
(apply string-append (apply string-append
@ -185,8 +184,8 @@
(list* l " " (loop))))))) (list* l " " (loop)))))))
'text)) 'text))
;; doesn't test graphing.ss teachpack ;; doesn't test graphing.ss teachpack
(define (test-built-in-teachpacks) (define (test-built-in-teachpacks)
(clear-definitions drs-frame) (clear-definitions drs-frame)
(type-in-definitions drs-frame "1") (type-in-definitions drs-frame "1")
(let* ([test-teachpack (let* ([test-teachpack
@ -224,7 +223,7 @@
(test-teachpacks (list (build-path teachpack-dir "2htdp") (test-teachpacks (list (build-path teachpack-dir "2htdp")
(build-path teachpack-dir "htdp"))))) (build-path teachpack-dir "htdp")))))
(define (find-leftmost-choice frame) (define (find-leftmost-choice frame)
(let loop ([p frame]) (let loop ([p frame])
(cond (cond
[(is-a? p list-box%) p] [(is-a? p list-box%) p]
@ -232,9 +231,14 @@
(ormap loop (send p get-children))] (ormap loop (send p get-children))]
[else #f]))) [else #f])))
(define (run-test) (define (run-test)
(set! drs-frame (wait-for-drscheme-frame)) (set! drs-frame (wait-for-drscheme-frame))
(set! interactions-text (send drs-frame get-interactions-text)) (set! interactions-text (send drs-frame get-interactions-text))
;(good-tests) ;(good-tests)
;(bad-tests) ;(bad-tests)
(test-built-in-teachpacks))) (test-built-in-teachpacks))
(let ()
(fire-up-drscheme)
(thread (λ () (run-test) (exit)))
(yield (make-semaphore)))

58
collects/tests/drscheme/tool.ss
View File

@ -1,58 +0,0 @@
;; load this file as a tool to run the test suites
(module tool mzscheme
(require drscheme/tool
mzlib/list
mzlib/unit
mzlib/class
mred
framework
"README.ss")
(provide tool@)
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1) (void))
(define (phase2) (void))
(preferences:set-default 'drscheme:test-suite:file-name "repl-tests.ss" string?)
(preferences:set-default 'drscheme:test-suite:run-interval 10 number?)
(preferences:set-default 'drscheme:test-suite:frame-width #f (lambda (x) (or (not x) (number? x))))
(preferences:set-default 'drscheme:test-suite:frame-height 300 (lambda (x) (or (not x) (number? x))))
(define (tool-mixin super%)
(class super%
(inherit get-button-panel)
(super-new)
(let* ([bitmap (make-object bitmap%
(if (<= (get-display-depth) 1)
(build-path (collection-path "icons") "bb-sm-bw.bmp")
(build-path (collection-path "icons") "bb-small.bmp"))
'bmp)]
[button (make-object button%
(if (send bitmap ok?) bitmap "Console")
(get-button-panel)
(lambda (button evt)
(let ([ask-test-suite (dynamic-require 'tests/drscheme/run-tests
'ask-test-suite)])
(ask-test-suite this))))])
(send (get-button-panel) change-children
(lambda (l)
(cons button (remq button l)))))))
(define tests (getenv "PLTDRTESTS"))
(cond
[(not tests) (void)]
[(member tests all-tests)
((dynamic-require 'tests/drscheme/run-tests 'run-test-suite)
tests
#t)]
[else
(printf "PLTDRTESTS: installing unit frame mixin\n")
(drscheme:get/extend:extend-unit-frame tool-mixin)]))))

4
collects/tests/info.ss
View File

@ -1,8 +1,8 @@
#lang setup/infotab #lang setup/infotab
(define name "Test Suites") (define name "Test Suites")
(define tools '(("tool.ss" "drscheme") ("time-keystrokes.ss" "drscheme"))) (define tools '(("time-keystrokes.ss" "drscheme")))
(define tool-names '("DrScheme Test Suites" "Time Keystrokes")) (define tool-names '("Time Keystrokes"))
(define compile-omit-paths (define compile-omit-paths
'("2htdp" '("2htdp"