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

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

@ -1,90 +1,89 @@
(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)
(define get-string/style-desc
(opt-lambda (text [start 0] [end (send text last-position)])
(let* ([snips (get-snips text start end)]
[str/ann (map snip->str/ann snips)]
[joined-str/ann (join-like str/ann)])
joined-str/ann)))
;; get-snips : text -> (listof snip)
;; extracts the snips from a text
(define (get-snips text start end)
(send text split-snip start)
(send text split-snip end)
(let loop ([snip (send text find-snip start 'after-or-none)])
(cond
[(not snip) null]
[(< (send text get-snip-position snip) end)
(cons snip (loop (send snip next)))]
[else null])))
;; snip->str/ann : snip -> str/ann
;; extracts the style type from the snip
(define (snip->str/ann snip)
(let* ([str (cond
[(is-a? snip string-snip%)
(send snip get-text 0 (send snip get-count))]
[(is-a? snip image-snip%)
'image]
[else 'unknown])]
[style (send snip get-style)]
[style-name (send style get-name)]
[style-desc (if style-name
(translate-name style-name)
(describe-style style))])
(list str style-desc)))
;; describe-style : style -> (listof symbol)
(define (describe-style style)
(list
'alignment (send style get-alignment)
'background (symbolic-color (send style get-background))
'face (send style get-face)
'family (send style get-family)
'foreground (symbolic-color (send style get-foreground))
'size (send style get-size)
'underlined (send style get-underlined)))
(define (symbolic-color color)
(list (send color red)
(send color green)
(send color blue)))
;; translate-name : (union #f string) -> symbol (provide get-string/style-desc)
;; translates the style name to a symbol (require scheme/gui/base
(define (translate-name str) scheme/class)
(and str
(let ([m (regexp-match re:translate-name str)]) ;; get-string/style-desc : text -> (listof str/ann)
(and m (define (get-string/style-desc text [start 0] [end (send text last-position)])
(string->symbol (cadr m)))))) (let* ([snips (get-snips text start end)]
[str/ann (map snip->str/ann snips)]
;; re:translate-name : regexp [joined-str/ann (join-like str/ann)])
(define re:translate-name (regexp "^.*:([^:]*)$")) joined-str/ann))
;; join-like : (listof str/ann) -> (listof str/ann) ;; get-snips : text -> (listof snip)
;; joins same styles to form largest groups ;; extracts the snips from a text
(define (join-like str/anns) (define (get-snips text start end)
(send text split-snip start)
(send text split-snip end)
(let loop ([snip (send text find-snip start 'after-or-none)])
(cond (cond
[(null? str/anns) null] [(not snip) null]
[else [(< (send text get-snip-position snip) end)
(let loop ([first (car str/anns)] (cons snip (loop (send snip next)))]
[rest (cdr str/anns)]) [else null])))
(cond
[(null? rest) (list first)] ;; snip->str/ann : snip -> str/ann
[else ;; extracts the style type from the snip
(let ([second (car rest)]) (define (snip->str/ann snip)
(if (and (equal? (cadr first) (cadr second)) (let* ([str (cond
(string? (car first)) [(is-a? snip string-snip%)
(string? (car second))) (send snip get-text 0 (send snip get-count))]
(loop (list (string-append (car first) (car second)) [(is-a? snip image-snip%)
(cadr first)) 'image]
(cdr rest)) [else 'unknown])]
(cons first [style (send snip get-style)]
(loop second [style-name (send style get-name)]
(cdr rest)))))]))]))) [style-desc (if style-name
(translate-name style-name)
(describe-style style))])
(list str style-desc)))
;; describe-style : style -> (listof symbol)
(define (describe-style style)
(list
'alignment (send style get-alignment)
'background (symbolic-color (send style get-background))
'face (send style get-face)
'family (send style get-family)
'foreground (symbolic-color (send style get-foreground))
'size (send style get-size)
'underlined (send style get-underlined)))
(define (symbolic-color color)
(list (send color red)
(send color green)
(send color blue)))
;; translate-name : (union #f string) -> symbol
;; translates the style name to a symbol
(define (translate-name str)
(and str
(let ([m (regexp-match re:translate-name str)])
(and m
(string->symbol (cadr m))))))
;; re:translate-name : regexp
(define re:translate-name (regexp "^.*:([^:]*)$"))
;; join-like : (listof str/ann) -> (listof str/ann)
;; joins same styles to form largest groups
(define (join-like str/anns)
(cond
[(null? str/anns) null]
[else
(let loop ([first (car str/anns)]
[rest (cdr str/anns)])
(cond
[(null? rest) (list first)]
[else
(let ([second (car rest)])
(if (and (equal? (cadr first) (cadr second))
(string? (car first))
(string? (car second)))
(loop (list (string-append (car first) (car second))
(cadr first))
(cdr rest))
(cons first
(loop second
(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
|#)))

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

@ -1,3 +1,5 @@
#lang scheme/base
#| #|
add this test: add this test:
@ -10,186 +12,191 @@ 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/pretty
mzlib/list mred
mzlib/pretty mrlib/text-string-style-desc)
mred
framework (define (check-output expression expected)
mrlib/text-string-style-desc (begin
(prefix fw: framework))
(provide run-test)
(define (output-err-port-checking)
(define (check-output expression expected)
(begin
(clear-definitions drs-frame)
(type-in-definitions drs-frame expression)
(do-execute drs-frame)
(let ([got (get-annotated-output)])
(unless (and (= (length expected)
(length got))
(andmap (λ (exp got)
(and (string=? (car exp) (car got))
(or (equal? (cadr exp) (cadr got))
(and (procedure? (cadr exp))
((cadr exp) (cadr got))))))
expected
got))
(fprintf (current-error-port)
"expected ~s, got ~s for ~s\n\n"
expected
got
expression)))))
(define (get-annotated-output)
(let ([chan (make-channel)])
(queue-callback
(λ ()
(let ([text (send drs-frame get-interactions-text)])
(channel-put chan
(get-string/style-desc text
(send text paragraph-start-position 2))))))
(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))
;; this test has to be first to test an uninitialized state of the port
(check-output "(port-next-location (current-input-port))"
(list `("1\n0\n1" |ports value|)
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-error-port))" (list (list "1" error-style) prompt))
(check-output "(display 1) (display 1 (current-error-port))"
(list (list "1" output-style)
(list "1" error-style)
prompt))
(check-output "(display 1 (current-error-port)) (display 1)"
(list (list "1" error-style)
(list "1" output-style)
prompt))
(check-output "(display 1) (display 1 (current-error-port)) (display 1)"
(list (list "1" output-style)
(list "1" error-style)
(list "1" output-style)
prompt))
(check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))"
(list (list "1" error-style)
(list "1" output-style)
(list "1" error-style)
prompt))
(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))"
(list (list "1" output-style)
prompt))
(check-output
"(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))"
(list (list "1" output-style)
prompt))
(check-output
"(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))"
(list (list "1" error-style)
prompt)))
(define (long-io/execute-test)
(let ([string-port (open-output-string)])
(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)))))
string-port)
(clear-definitions drs-frame)
(type-in-definitions
drs-frame
"(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))")
(do-execute drs-frame)
(let ([got-output (fetch-output drs-frame)])
(clear-definitions drs-frame)
(do-execute drs-frame)
(unless (equal? "" (fetch-output drs-frame))
(error 'io.ss "failed long io / execute test (extra io)"))
(unless (whitespace-string=?
(get-output-string string-port)
got-output)
(error 'io.ss "failed long io / execute test (output doesn't match)")))))
(define (reading-test)
(define (do-input-test program input expected-transcript)
(do-execute drs-frame)
(type-in-interactions drs-frame program)
(let ([before-newline-pos (send interactions-text last-position)])
(type-in-interactions drs-frame (string #\newline))
(wait (λ ()
;; the focus moves to the input box, so wait for that.
(send interactions-text get-focus-snip))
"input box didn't appear")
(type-string input)
(wait-for-computation drs-frame)
(let ([got-value
(fetch-output drs-frame
(send interactions-text paragraph-start-position 3) ;; start after test expression
(send interactions-text paragraph-end-position
(- (send interactions-text last-paragraph) 1)))])
(unless (equal? got-value expected-transcript)
(printf "FAILED: expected: ~s~n got: ~s~n program: ~s~n input: ~s~n"
expected-transcript got-value program input)))))
(clear-definitions drs-frame) (clear-definitions drs-frame)
(do-input-test "(read-char)" "a\n" "a\n#\\a") (type-in-definitions drs-frame expression)
(do-input-test "(read-char)" "λ\n" "λ\n#\\λ") (do-execute drs-frame)
(do-input-test "(read-line)" "abcdef\n" "abcdef\n\"abcdef\"") (let ([got (get-annotated-output)])
(do-input-test "(list (read-char) (read-line))" "abcdef\n" "abcdef\n(#\\a \"bcdef\")") (unless (and (= (length expected)
(length got))
(andmap (λ (exp got)
(and (string=? (car exp) (car got))
(or (equal? (cadr exp) (cadr got))
(and (procedure? (cadr exp))
((cadr exp) (cadr got))))))
expected
got))
(fprintf (current-error-port)
"expected ~s\n got ~s\nfor ~s\n\n"
expected
got
expression)))))
(do-input-test "(read)" "a\n" "a\na") (define (get-annotated-output)
(do-input-test "(list (read) (read))" "a a\n" "a a\n(a a)") (let ([chan (make-channel)])
(do-input-test "(list (read-char) (read))" "aa\n" "aa\n(#\\a a)") (queue-callback
(λ ()
(do-input-test "(begin (read-char) (sleep 1) (read-char))" "ab\ncd\n" "ab\ncd\n#\\b") (let ([text (send drs-frame get-interactions-text)])
(do-input-test "(list (read) (sleep 1) (read) (read))" "a b\nc d\n" "a b\nc d\n(a #<void> b c)") (channel-put chan
(get-string/style-desc text
(do-input-test "(begin (display 1) (read))" "2\n" "12\n2\n") ;; why an extra newline?! (send text paragraph-start-position 2))))))
(channel-get chan)))
(do-input-test "(read-line)" "\n" "\n\"\"")
(do-input-test "(read-char)" "\n" "\n#\\newline")
(do-input-test "(list (read) (printf \"1~n\") (read) (printf \"3~n\"))"
"0 2\n" (define (output-style x) (eq? x '|ports out|))
"0 2\n1\n3\n(0 #<void> 2 #<void>)") (define (error-style x) (eq? x '|ports err|))
(define (value-style x) (eq? x '|ports value|))
(do-input-test "(write (read))"
"()\n" (define prompt '("\n> " default-color))
"()\n()")
(define (output-err-port-checking)
(do-input-test "(begin (write (read)) (write (read)))" ;; this test has to be first to test an uninitialized state of the port
"(1)\n(2)\n" (check-output "(port-next-location (current-input-port))"
"(1)\n(1)(2)\n(2)") (list `("1\n0\n1\n" |ports value|)
'("> " default-color)))
(do-input-test
(string-append "(let ([b (read-byte)][bs0 (bytes 0)][bs1 (bytes 1)][bs2 (bytes 2)])"
"(read-bytes-avail!* bs0)"
"(read-bytes-avail!* bs1)"
"(read-bytes-avail!* bs2)"
"(list b bs0 bs1 bs2))\n")
"ab\n"
"ab\n(97 #\"b\" #\"\\n\" #\"\\2\")"))
(define drs-frame #f) (check-output "(display 1)" (list (list "1" output-style) prompt))
(define interactions-text #f) (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt))
(define (run-test) (check-output "(display 1 (current-error-port))" (list (list "1" error-style) prompt))
(set! drs-frame (wait-for-drscheme-frame)) (check-output "(display 1) (display 1 (current-error-port))"
(set! interactions-text (send drs-frame get-interactions-text)) (list (list "1" output-style)
(set-language-level! (list #rx"Pretty Big")) (list "1" error-style)
(output-err-port-checking) ;; must come first prompt))
;(long-io/execute-test) (check-output "(display 1 (current-error-port)) (display 1)"
(reading-test) (list (list "1" error-style)
)) (list "1" output-style)
prompt))
(check-output "(display 1) (display 1 (current-error-port)) (display 1)"
(list (list "1" output-style)
(list "1" error-style)
(list "1" output-style)
prompt))
(check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))"
(list (list "1" error-style)
(list "1" output-style)
(list "1" error-style)
prompt))
(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))"
(list (list "1" output-style)
prompt))
(check-output
"(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))"
(list (list "1" output-style)
prompt))
(check-output
"(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))"
(list (list "1" error-style)
prompt)))
(define (long-io/execute-test)
(let ([string-port (open-output-string)])
(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)))))
string-port)
(clear-definitions drs-frame)
(type-in-definitions
drs-frame
"(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))")
(do-execute drs-frame)
(let ([got-output (fetch-output drs-frame)])
(clear-definitions drs-frame)
(do-execute drs-frame)
(unless (equal? "" (fetch-output drs-frame))
(error 'io.ss "failed long io / execute test (extra io)"))
(unless (whitespace-string=?
(get-output-string string-port)
got-output)
(error 'io.ss "failed long io / execute test (output doesn't match)")))))
(define (reading-test)
(define (do-input-test program input expected-transcript)
(do-execute drs-frame)
(type-in-interactions drs-frame program)
(let ([before-newline-pos (send interactions-text last-position)])
(type-in-interactions drs-frame (string #\newline))
(wait (λ ()
;; the focus moves to the input box, so wait for that.
(send interactions-text get-focus-snip))
"input box didn't appear")
(type-string input)
(wait-for-computation drs-frame)
(let ([got-value
(fetch-output drs-frame
(send interactions-text paragraph-start-position 3) ;; start after test expression
(send interactions-text paragraph-end-position
(- (send interactions-text last-paragraph) 1)))])
(unless (equal? got-value expected-transcript)
(fprintf (current-error-port)
"FAILED: expected: ~s~n got: ~s~n program: ~s~n input: ~s~n"
expected-transcript got-value program input)))))
(clear-definitions drs-frame)
(do-input-test "(read-char)" "a\n" "a\n#\\a")
(do-input-test "(read-char)" "λ\n" "λ\n#\\λ")
(do-input-test "(read-line)" "abcdef\n" "abcdef\n\"abcdef\"")
(do-input-test "(list (read-char) (read-line))" "abcdef\n" "abcdef\n(#\\a \"bcdef\")")
(do-input-test "(read)" "a\n" "a\na")
(do-input-test "(list (read) (read))" "a a\n" "a a\n(a a)")
(do-input-test "(list (read-char) (read))" "aa\n" "aa\n(#\\a a)")
(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 "(begin (display 1) (read))" "2\n" "12\n2")
(do-input-test "(read-line)" "\n" "\n\"\"")
(do-input-test "(read-char)" "\n" "\n#\\newline")
(do-input-test "(list (read) (printf \"1~n\") (read) (printf \"3~n\"))"
"0 2\n"
"0 2\n1\n3\n(0 #<void> 2 #<void>)")
(do-input-test "(write (read))"
"()\n"
"()\n()")
(do-input-test "(begin (write (read)) (flush-output) (write (read)))"
"(1)\n(2)\n"
"(1)\n(1)(2)\n(2)")
(do-input-test
(string-append "(let ([b (read-byte)][bs0 (bytes 0)][bs1 (bytes 1)][bs2 (bytes 2)])"
"(read-bytes-avail!* bs0)"
"(read-bytes-avail!* bs1)"
"(read-bytes-avail!* bs2)"
"(list b bs0 bs1 bs2))\n")
"ab\n"
"ab\n(97 #\"b\" #\"\\n\" #\"\\2\")"))
(define drs-frame #f)
(define interactions-text #f)
(let ([s (make-semaphore)])
(fire-up-drscheme)
(thread
(λ ()
(set! drs-frame (wait-for-drscheme-frame))
(set! interactions-text (send drs-frame get-interactions-text))
(set-language-level! (list #rx"Pretty Big"))
(clear-definitions drs-frame)
(do-execute drs-frame)
(output-err-port-checking) ;; must come first
;(long-io/execute-test)
(reading-test)
(semaphore-post s)))
(yield s)
(exit))

36
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,8 +1043,9 @@ 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)
(language) setting-name expression result got))))) "FAILED: ~s ~s ~s test~n expected: ~s~n got: ~s~n"
(language) setting-name expression result got)))))
(define (test-hash-bang) (define (test-hash-bang)
(let* ([expression "#!/bin/sh\n1"] (let* ([expression "#!/bin/sh\n1"]
@ -1058,8 +1057,9 @@ 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)
(language) expression result got))))) "FAILED: ~s ~a test~n expected: ~s~n got: ~s~n"
(language) expression result got)))))
(define (fetch-output/should-be-tested . args) (define (fetch-output/should-be-tested . args)
(regexp-replace (regexp (regexp-replace (regexp
@ -1094,9 +1094,10 @@ 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)
line0-expect line1-expect "expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n"
line0-got line1-got) line0-expect line1-expect
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,10 +1177,11 @@ 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)
(language) option show-sharing pretty? "FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n"
(shorten got) (language) option show-sharing pretty?
(if (procedure? answer) (answer) answer)))))]) (shorten got)
(if (procedure? answer) (answer) answer)))))])
(clear-definitions drs) (clear-definitions drs)
(type-in-definitions drs expression) (type-in-definitions drs expression)
@ -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)))

27
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,12 +108,13 @@
[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)
(test-line test) "FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n"
(test-definitions test) (test-line test)
(or (test-interactions test) 'no-interactions) (test-definitions test)
(test-result test) (or (test-interactions test) 'no-interactions)
text)) (test-result test)
text))
(cond (cond
[(eq? (test-error-ranges test) 'dont-test) [(eq? (test-error-ranges test) 'dont-test)
(void)] (void)]
@ -120,11 +122,12 @@
(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)
(test-line test) "FAILED (line ~a; ranges): ~a\n expected: ~s\n got: ~s\n"
(test-definitions test) (test-line test)
error-ranges-expected (test-definitions test)
(send interactions-text get-error-ranges))))]))))) error-ranges-expected
(send interactions-text get-error-ranges))))])))))
(define drs 'not-yet-drs-frame) (define drs 'not-yet-drs-frame)

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)))

56
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,12 +1184,14 @@ 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)
program))] "FAILED execute test for ~s\n expected definitions to have the focus\n"
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)
program))] "FAILED execute test for ~s\n expected interactions to have the focus\n"
program))]
[(send definitions-canvas has-focus?) [(send definitions-canvas has-focus?)
(let ([start (car source-location)] (let ([start (car source-location)]
[finish (cdr source-location)]) [finish (cdr source-location)])
@ -1203,13 +1203,14 @@ 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)
program "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
(and error-range program
(list (+ (srcloc-position error-range) -1) (and error-range
(+ (srcloc-position error-range) -1 (srcloc-span error-range)))) (list (+ (srcloc-position error-range) -1)
(list (loc-offset start) (+ (srcloc-position error-range) -1 (srcloc-span error-range))))
(loc-offset finish))))))])]) (list (loc-offset start)
(loc-offset finish))))))])])
; check text for execute test ; check text for execute test
(next-test) (next-test)
@ -1220,10 +1221,11 @@ 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)
program "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
language-cust program
execute-answer received-execute)) language-cust
execute-answer received-execute))
(test:new-window interactions-canvas) (test:new-window interactions-canvas)
@ -1274,9 +1276,10 @@ 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)
short-filename "FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n"
program load-answer received-load)))))]) short-filename
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))
(when (file-exists? tmp-load3-filename) (when (file-exists? tmp-load3-filename)
(delete-file tmp-load3-filename)) (delete-file tmp-load3-filename))
@ -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))))

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

@ -1,240 +1,244 @@
#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)
(define drs-frame 'not-yet-drs-frame)
(define interactions-text 'not-yet-interactions-text)
(define good-teachpack-name "teachpack-tmp~a")
(define (test-good-teachpack tp-exps dr-exp expected)
(clear-definitions drs-frame)
(type-in-definitions drs-frame dr-exp)
(fw:test:menu-select "Language" "Clear All Teachpacks")
(provide run-test) (let ([tp-names
(let ([teachpack-path (normal-case-path
(define drs-frame 'not-yet-drs-frame) (normalize-path
(define interactions-text 'not-yet-interactions-text) (collection-path "tests" "drscheme")))])
(let loop ([tp-exps tp-exps]
(define good-teachpack-name "teachpack-tmp~a") [n 0])
(cond
(define (test-good-teachpack tp-exps dr-exp expected) [(null? tp-exps) null]
(clear-definitions drs-frame) [else
(type-in-definitions drs-frame dr-exp) (let ([tp-name (build-path teachpack-path
(fw:test:menu-select "Language" "Clear All Teachpacks") (string-append
(format good-teachpack-name n)
".ss"))])
(call-with-output-file tp-name
(lambda (port) (write (car tp-exps) port))
'truncate)
(use-get/put-dialog
(lambda ()
(fw:test:menu-select "Language" "Add Teachpack..."))
tp-name)
(cons tp-name (loop (cdr tp-exps) (+ n 1))))])))])
(let ([tp-names
(let ([teachpack-path (normal-case-path
(normalize-path
(collection-path "tests" "drscheme")))])
(let loop ([tp-exps tp-exps]
[n 0])
(cond
[(null? tp-exps) null]
[else
(let ([tp-name (build-path teachpack-path
(string-append
(format good-teachpack-name n)
".ss"))])
(call-with-output-file tp-name
(lambda (port) (write (car tp-exps) port))
'truncate)
(use-get/put-dialog
(lambda ()
(fw:test:menu-select "Language" "Add Teachpack..."))
tp-name)
(cons tp-name (loop (cdr tp-exps) (+ n 1))))])))])
(do-execute drs-frame)
(let ([got (fetch-output drs-frame)]
[full-expectation
(string-append
(apply string-append (map (lambda (x) (format "Teachpack: ~a.~n" x)) tp-names))
expected
"\nThis psorgram should be tested.")])
(unless (equal? got
full-expectation)
(printf
"FAILED: tp: ~s~n exp: ~s~n expected: ~s~n got: ~s~n"
tp-exps
dr-exp
full-expectation
got)))))
;; there are no more errors when the teachpack is loaded (for now...)
(define (test-bad/load-teachpack tp-exp expected-error)
(fw:test:menu-select "Language" "Clear All Teachpacks")
(let ([tp-name (normal-case-path
(normalize-path
(build-path
(collection-path "tests" "drscheme")
"teachpack-tmp.ss")))])
(call-with-output-file tp-name
(lambda (port) (display tp-exp port))
'truncate)
(use-get/put-dialog
(lambda ()
(fw:test:menu-select "Language" "Add Teachpack..."))
tp-name)
(let ([dialog
(with-handlers ([(lambda (x) #t)
(lambda (x) #f)])
(wait-for-new-frame drs-frame))])
(cond
[dialog
(let ([got (send dialog get-message)])
(unless (string=? got expected-error)
(printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n"
tp-exp expected-error got))
(fw:test:button-push "Ok")
(wait-for-new-frame dialog))]
[else
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n"
tp-exp expected-error)]))))
(define (test-bad/execute-teachpack tp-exp expected)
(fw:test:menu-select "Language" "Clear All Teachpacks")
(let ([tp-name (normal-case-path
(normalize-path
(build-path
(collection-path "tests" "drscheme")
"teachpack-tmp.ss")))])
(call-with-output-file tp-name
(lambda (port) (display tp-exp port))
'truncate)
(use-get/put-dialog
(lambda ()
(fw:test:menu-select "Language" "Add Teachpack..."))
tp-name)
(do-execute drs-frame #f)
(let ([dialog
(with-handlers ([exn:fail? (lambda (x) #f)])
(let ([wait-for-error-pred
(lambda ()
(let ([active
(or
(get-top-level-focus-window)
(and (send interactions-text get-user-eventspace)
(parameterize ([current-eventspace
(send interactions-text get-user-eventspace)])
(get-top-level-focus-window))))])
(if (and active (not (eq? active drs-frame)))
active
#f)))])
(poll-until wait-for-error-pred)))])
(cond
[dialog
(let ([got (send dialog get-message)]
[expected-error
(string-append (format "Invalid Teachpack: ~a~n" tp-name)
expected)])
(unless (string=? got expected-error)
(printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n"
tp-exp expected-error got))
(fw:test:button-push "Ok")
(wait-for-new-frame dialog))]
[else
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n"
tp-exp error)]))))
(define (generic-tests)
(test-good-teachpack
(list
`(module ,(string->symbol (format good-teachpack-name 0)) mzscheme))
"1"
"1")
(test-good-teachpack
(list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme
(provide not-a-primitive)
(define not-a-primitive 1)))
"not-a-primitive"
"1")
(test-good-teachpack
(list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme
(provide not-a-primitive1)
(define not-a-primitive1 1))
`(module ,(string->symbol (format good-teachpack-name 1)) mzscheme
(provide not-a-primitive2)
(define not-a-primitive2 2)))
"(+ not-a-primitive1 not-a-primitive2)"
"3"))
(define (good-tests)
(set-language-level! '("How to Design Programs" "Beginning Student"))
(do-execute drs-frame) (do-execute drs-frame)
(generic-tests))
(define (bad-tests)
(set-language-level! '("How to Design Programs" "Beginning Student"))
(test-bad/execute-teachpack (let ([got (fetch-output drs-frame)]
"undefined-id" [full-expectation
"reference to undefined identifier: undefined-id") (string-append
(apply string-append (map (lambda (x) (format "Teachpack: ~a.~n" x)) tp-names))
(test-bad/execute-teachpack expected
`(module teachpack-tmp mzscheme (car)) "\nThis psorgram should be tested.")])
"car: expects argument of type <pair>; given 1")) (unless (equal? got
full-expectation)
(define (get-string-from-file fn) (printf
(call-with-input-file fn "FAILED: tp: ~s~n exp: ~s~n expected: ~s~n got: ~s~n"
(lambda (port) tp-exps
(apply string-append dr-exp
(let loop () full-expectation
(let ([l (read-line port)]) got)))))
(if (eof-object? l)
null ;; there are no more errors when the teachpack is loaded (for now...)
(list* l " " (loop))))))) (define (test-bad/load-teachpack tp-exp expected-error)
'text)) (fw:test:menu-select "Language" "Clear All Teachpacks")
(let ([tp-name (normal-case-path
;; doesn't test graphing.ss teachpack (normalize-path
(define (test-built-in-teachpacks) (build-path
(clear-definitions drs-frame) (collection-path "tests" "drscheme")
(type-in-definitions drs-frame "1") "teachpack-tmp.ss")))])
(let* ([test-teachpack (call-with-output-file tp-name
(lambda (dir) (lambda (port) (display tp-exp port))
(lambda (teachpack) 'truncate)
(when (or (equal? #"ss" (filename-extension teachpack)) (use-get/put-dialog
(equal? #"scm" (filename-extension teachpack))) (lambda ()
(unless (equal? "graphing.ss" (path->string teachpack)) (fw:test:menu-select "Language" "Add Teachpack..."))
(printf " testing ~a~n" teachpack) tp-name)
(fw:test:menu-select "Language" "Clear All Teachpacks") (let ([dialog
(fw:test:menu-select "Language" "Add Teachpack...") (with-handlers ([(lambda (x) #t)
(wait-for-new-frame drs-frame) (lambda (x) #f)])
(let* ([tp-dialog (get-top-level-focus-window)] (wait-for-new-frame drs-frame))])
[choice (find-leftmost-choice tp-dialog)])
(fw:test:set-list-box! choice (path->string teachpack))
(fw:test:button-push "OK")
(wait-for-new-frame tp-dialog))
(do-execute drs-frame)
(let ([got (fetch-output drs-frame)]
[expected (format "Teachpack: ~a.\n1"
(path->string teachpack))])
(unless (equal? got expected)
(printf "FAILED built in teachpack test: ~a~n" (path->string teachpack))
(printf " got: ~s~n expected: ~s~n" got expected)))))))]
[test-teachpacks
(lambda (paths)
(for-each (lambda (dir)
(for-each (test-teachpack dir)
(directory-list dir)))
paths))]
[teachpack-dir (normalize-path (collection-path "teachpack"))])
(set-language-level! '("How to Design Programs" "Advanced Student"))
(do-execute drs-frame)
(test-teachpacks (list (build-path teachpack-dir "2htdp")
(build-path teachpack-dir "htdp")))))
(define (find-leftmost-choice frame)
(let loop ([p frame])
(cond (cond
[(is-a? p list-box%) p] [dialog
[(is-a? p area-container<%>) (let ([got (send dialog get-message)])
(ormap loop (send p get-children))] (unless (string=? got expected-error)
[else #f]))) (printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n"
tp-exp expected-error got))
(fw:test:button-push "Ok")
(wait-for-new-frame dialog))]
[else
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n"
tp-exp expected-error)]))))
(define (test-bad/execute-teachpack tp-exp expected)
(fw:test:menu-select "Language" "Clear All Teachpacks")
(let ([tp-name (normal-case-path
(normalize-path
(build-path
(collection-path "tests" "drscheme")
"teachpack-tmp.ss")))])
(call-with-output-file tp-name
(lambda (port) (display tp-exp port))
'truncate)
(use-get/put-dialog
(lambda ()
(fw:test:menu-select "Language" "Add Teachpack..."))
tp-name)
(do-execute drs-frame #f)
(let ([dialog
(with-handlers ([exn:fail? (lambda (x) #f)])
(let ([wait-for-error-pred
(lambda ()
(let ([active
(or
(get-top-level-focus-window)
(and (send interactions-text get-user-eventspace)
(parameterize ([current-eventspace
(send interactions-text get-user-eventspace)])
(get-top-level-focus-window))))])
(if (and active (not (eq? active drs-frame)))
active
#f)))])
(poll-until wait-for-error-pred)))])
(cond
[dialog
(let ([got (send dialog get-message)]
[expected-error
(string-append (format "Invalid Teachpack: ~a~n" tp-name)
expected)])
(unless (string=? got expected-error)
(printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n"
tp-exp expected-error got))
(fw:test:button-push "Ok")
(wait-for-new-frame dialog))]
[else
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n"
tp-exp error)]))))
(define (generic-tests)
(test-good-teachpack
(list
`(module ,(string->symbol (format good-teachpack-name 0)) mzscheme))
"1"
"1")
(define (run-test) (test-good-teachpack
(set! drs-frame (wait-for-drscheme-frame)) (list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme
(set! interactions-text (send drs-frame get-interactions-text)) (provide not-a-primitive)
;(good-tests) (define not-a-primitive 1)))
;(bad-tests) "not-a-primitive"
(test-built-in-teachpacks))) "1")
(test-good-teachpack
(list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme
(provide not-a-primitive1)
(define not-a-primitive1 1))
`(module ,(string->symbol (format good-teachpack-name 1)) mzscheme
(provide not-a-primitive2)
(define not-a-primitive2 2)))
"(+ not-a-primitive1 not-a-primitive2)"
"3"))
(define (good-tests)
(set-language-level! '("How to Design Programs" "Beginning Student"))
(do-execute drs-frame)
(generic-tests))
(define (bad-tests)
(set-language-level! '("How to Design Programs" "Beginning Student"))
(test-bad/execute-teachpack
"undefined-id"
"reference to undefined identifier: undefined-id")
(test-bad/execute-teachpack
`(module teachpack-tmp mzscheme (car))
"car: expects argument of type <pair>; given 1"))
(define (get-string-from-file fn)
(call-with-input-file fn
(lambda (port)
(apply string-append
(let loop ()
(let ([l (read-line port)])
(if (eof-object? l)
null
(list* l " " (loop)))))))
'text))
;; doesn't test graphing.ss teachpack
(define (test-built-in-teachpacks)
(clear-definitions drs-frame)
(type-in-definitions drs-frame "1")
(let* ([test-teachpack
(lambda (dir)
(lambda (teachpack)
(when (or (equal? #"ss" (filename-extension teachpack))
(equal? #"scm" (filename-extension teachpack)))
(unless (equal? "graphing.ss" (path->string teachpack))
(printf " testing ~a~n" teachpack)
(fw:test:menu-select "Language" "Clear All Teachpacks")
(fw:test:menu-select "Language" "Add Teachpack...")
(wait-for-new-frame drs-frame)
(let* ([tp-dialog (get-top-level-focus-window)]
[choice (find-leftmost-choice tp-dialog)])
(fw:test:set-list-box! choice (path->string teachpack))
(fw:test:button-push "OK")
(wait-for-new-frame tp-dialog))
(do-execute drs-frame)
(let ([got (fetch-output drs-frame)]
[expected (format "Teachpack: ~a.\n1"
(path->string teachpack))])
(unless (equal? got expected)
(printf "FAILED built in teachpack test: ~a~n" (path->string teachpack))
(printf " got: ~s~n expected: ~s~n" got expected)))))))]
[test-teachpacks
(lambda (paths)
(for-each (lambda (dir)
(for-each (test-teachpack dir)
(directory-list dir)))
paths))]
[teachpack-dir (normalize-path (collection-path "teachpack"))])
(set-language-level! '("How to Design Programs" "Advanced Student"))
(do-execute drs-frame)
(test-teachpacks (list (build-path teachpack-dir "2htdp")
(build-path teachpack-dir "htdp")))))
(define (find-leftmost-choice frame)
(let loop ([p frame])
(cond
[(is-a? p list-box%) p]
[(is-a? p area-container<%>)
(ormap loop (send p get-children))]
[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))
(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"