drdr-ized the rest of the drscheme test suite
svn: r17945
This commit is contained in:
Robby Findler
parent
8d2f32efed
commit
e74e46d9ca
|
|
@ -1,20 +1,19 @@
|
|||
(module text-string-style-desc mzscheme
|
||||
(provide get-string/style-desc)
|
||||
(require mred
|
||||
mzlib/etc
|
||||
mzlib/class)
|
||||
#lang scheme/base
|
||||
|
||||
;; get-string/style-desc : text -> (listof str/ann)
|
||||
(define get-string/style-desc
|
||||
(opt-lambda (text [start 0] [end (send text last-position)])
|
||||
(provide get-string/style-desc)
|
||||
(require scheme/gui/base
|
||||
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)]
|
||||
[str/ann (map snip->str/ann snips)]
|
||||
[joined-str/ann (join-like str/ann)])
|
||||
joined-str/ann)))
|
||||
joined-str/ann))
|
||||
|
||||
;; get-snips : text -> (listof snip)
|
||||
;; extracts the snips from a text
|
||||
(define (get-snips text start end)
|
||||
;; 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)])
|
||||
|
|
@ -24,9 +23,9 @@
|
|||
(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)
|
||||
;; 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))]
|
||||
|
|
@ -40,8 +39,8 @@
|
|||
(describe-style style))])
|
||||
(list str style-desc)))
|
||||
|
||||
;; describe-style : style -> (listof symbol)
|
||||
(define (describe-style style)
|
||||
;; describe-style : style -> (listof symbol)
|
||||
(define (describe-style style)
|
||||
(list
|
||||
'alignment (send style get-alignment)
|
||||
'background (symbolic-color (send style get-background))
|
||||
|
|
@ -51,25 +50,25 @@
|
|||
'size (send style get-size)
|
||||
'underlined (send style get-underlined)))
|
||||
|
||||
(define (symbolic-color color)
|
||||
(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)
|
||||
;; 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 "^.*:([^:]*)$"))
|
||||
;; 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)
|
||||
;; 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
|
||||
|
|
@ -87,4 +86,4 @@
|
|||
(cdr rest))
|
||||
(cons first
|
||||
(loop second
|
||||
(cdr rest)))))]))])))
|
||||
(cdr rest)))))]))]))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|#)))
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
#lang scheme/base
|
||||
|
||||
#|
|
||||
|
||||
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
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mzlib/pretty
|
||||
mred
|
||||
framework
|
||||
mrlib/text-string-style-desc
|
||||
(prefix fw: framework))
|
||||
mrlib/text-string-style-desc)
|
||||
|
||||
(provide run-test)
|
||||
|
||||
(define (output-err-port-checking)
|
||||
(define (check-output expression expected)
|
||||
(define (check-output expression expected)
|
||||
(begin
|
||||
(clear-definitions drs-frame)
|
||||
(type-in-definitions drs-frame expression)
|
||||
|
|
@ -40,12 +35,12 @@ add this test:
|
|||
expected
|
||||
got))
|
||||
(fprintf (current-error-port)
|
||||
"expected ~s, got ~s for ~s\n\n"
|
||||
"expected ~s\n got ~s\nfor ~s\n\n"
|
||||
expected
|
||||
got
|
||||
expression)))))
|
||||
|
||||
(define (get-annotated-output)
|
||||
(define (get-annotated-output)
|
||||
(let ([chan (make-channel)])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
|
|
@ -55,16 +50,18 @@ add this test:
|
|||
(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))
|
||||
(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
|
||||
(check-output "(port-next-location (current-input-port))"
|
||||
(list `("1\n0\n1" |ports value|)
|
||||
prompt))
|
||||
(list `("1\n0\n1\n" |ports value|)
|
||||
'("> " default-color)))
|
||||
|
||||
(check-output "(display 1)" (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)
|
||||
prompt)))
|
||||
|
||||
(define (long-io/execute-test)
|
||||
(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)))))
|
||||
|
|
@ -121,7 +118,7 @@ add this test:
|
|||
(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)
|
||||
(do-execute drs-frame)
|
||||
(type-in-interactions drs-frame program)
|
||||
|
|
@ -140,7 +137,8 @@ add this test:
|
|||
(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"
|
||||
(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)
|
||||
|
|
@ -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 "(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-char)" "\n" "\n#\\newline")
|
||||
|
|
@ -169,7 +167,7 @@ add this test:
|
|||
"()\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(1)(2)\n(2)")
|
||||
|
||||
|
|
@ -182,14 +180,23 @@ add this test:
|
|||
"ab\n"
|
||||
"ab\n(97 #\"b\" #\"\\n\" #\"\\2\")"))
|
||||
|
||||
(define drs-frame #f)
|
||||
(define interactions-text #f)
|
||||
(define drs-frame #f)
|
||||
(define interactions-text #f)
|
||||
|
||||
(define (run-test)
|
||||
(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))
|
||||
|
||||
|
|
|
|||
|
|
@ -20,8 +20,6 @@ the settings above should match r5rs
|
|||
framework
|
||||
(prefix-in fw: framework))
|
||||
|
||||
(provide run-test)
|
||||
|
||||
(define language (make-parameter "<<not a language>>"))
|
||||
|
||||
;; set-language : boolean -> void
|
||||
|
|
@ -1045,7 +1043,8 @@ the settings above should match r5rs
|
|||
(do-execute drs)
|
||||
(let* ([got (fetch-output/should-be-tested drs)])
|
||||
(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)))))
|
||||
|
||||
(define (test-hash-bang)
|
||||
|
|
@ -1058,7 +1057,8 @@ the settings above should match r5rs
|
|||
(do-execute drs)
|
||||
(let* ([got (fetch-output/should-be-tested drs)])
|
||||
(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)))))
|
||||
|
||||
(define (fetch-output/should-be-tested . args)
|
||||
|
|
@ -1094,7 +1094,8 @@ the settings above should match r5rs
|
|||
(min (string-length line1-expect)
|
||||
(string-length 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-got line1-got)
|
||||
(error 'language-test.ss "failed get top of repl test")))))
|
||||
|
|
@ -1176,7 +1177,8 @@ the settings above should match r5rs
|
|||
(unless (if (procedure? answer)
|
||||
(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?
|
||||
(shorten got)
|
||||
(if (procedure? answer) (answer) answer)))))])
|
||||
|
|
@ -1244,7 +1246,8 @@ the settings above should match r5rs
|
|||
(send interactions-text paragraph-end-position
|
||||
(- (send interactions-text last-paragraph) 1)))])
|
||||
(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)))
|
||||
|
|
@ -1348,3 +1351,8 @@ the settings above should match r5rs
|
|||
(go advanced)
|
||||
(go pretty-big)
|
||||
(go r5rs))
|
||||
|
||||
(let ()
|
||||
(fire-up-drscheme)
|
||||
(thread (λ () (run-test) (exit)))
|
||||
(yield (make-semaphore)))
|
||||
|
|
@ -75,7 +75,8 @@
|
|||
(send interactions-text paragraph-start-position 2)
|
||||
(send interactions-text paragraph-end-position 2))])
|
||||
(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-definitions test)
|
||||
(or (test-interactions test) 'no-interactions)
|
||||
|
|
@ -107,7 +108,8 @@
|
|||
[else 'module-lang-test "bad test value: ~e" r])
|
||||
r text))])
|
||||
(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-definitions test)
|
||||
(or (test-interactions test) 'no-interactions)
|
||||
|
|
@ -120,7 +122,8 @@
|
|||
(let ([error-ranges-expected
|
||||
((test-error-ranges test) definitions-text interactions-text)])
|
||||
(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-definitions test)
|
||||
error-ranges-expected
|
||||
|
|
|
|||
|
|
@ -262,3 +262,10 @@
|
|||
(current-namespace (make-base-empty-namespace))}
|
||||
"(+ 1 2)"
|
||||
"3")
|
||||
|
||||
|
||||
(require "drscheme-test-util.ss")
|
||||
(let ()
|
||||
(fire-up-drscheme)
|
||||
(thread (λ () (run-test) (exit)))
|
||||
(yield (make-semaphore 0)))
|
||||
|
|
@ -17,8 +17,6 @@ This produces an ACK message
|
|||
mred
|
||||
framework)
|
||||
|
||||
(provide run-test)
|
||||
|
||||
(define-struct loc (line col offset))
|
||||
;; loc = (make-loc number number number)
|
||||
;; all numbers in loc structs start at zero.
|
||||
|
|
@ -1186,11 +1184,13 @@ This produces an ACK message
|
|||
(cond
|
||||
[(eq? source-location 'definitions)
|
||||
(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))]
|
||||
[(eq? source-location 'interactions)
|
||||
(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))]
|
||||
[(send definitions-canvas has-focus?)
|
||||
(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 (srcloc-span error-range))
|
||||
(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
|
||||
(and error-range
|
||||
(list (+ (srcloc-position error-range) -1)
|
||||
|
|
@ -1220,7 +1221,8 @@ This produces an ACK message
|
|||
(regexp-match execute-answer received-execute)]
|
||||
[else #f])
|
||||
(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
|
||||
language-cust
|
||||
execute-answer received-execute))
|
||||
|
|
@ -1274,7 +1276,8 @@ This produces an ACK message
|
|||
(regexp-match load-answer received-load)]
|
||||
[else #f])
|
||||
(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
|
||||
program load-answer received-load)))))])
|
||||
(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
|
||||
(when (repl-in-edit-sequence?)
|
||||
(printf "FAILED: repl in edit-sequence")
|
||||
(fprintf (current-error-port) "FAILED: repl in edit-sequence")
|
||||
(escape)))))
|
||||
|
||||
(define tests 0)
|
||||
|
|
@ -1298,7 +1301,7 @@ This produces an ACK message
|
|||
(define (final-report)
|
||||
(if (= 0 failures)
|
||||
(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)
|
||||
(let ([level (list #rx"Pretty Big")])
|
||||
|
|
@ -1470,8 +1473,7 @@ This produces an ACK message
|
|||
(kill-tests)
|
||||
(callcc-test)
|
||||
(top-interaction-test)
|
||||
(final-report)
|
||||
)
|
||||
(final-report))
|
||||
|
||||
(define (insert-in-definitions/newlines drs str)
|
||||
(let loop ([strs (regexp-split #rx"\n" str)])
|
||||
|
|
@ -1504,3 +1506,9 @@ This produces an ACK message
|
|||
(if (regexp? b)
|
||||
(regexp (string-append (regexp-quote a) (object-name b)))
|
||||
(string-append a b)))
|
||||
|
||||
|
||||
(let ()
|
||||
(fire-up-drscheme)
|
||||
(thread (λ () (run-test) (exit)))
|
||||
(yield (make-semaphore 0)))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -1,20 +1,19 @@
|
|||
#lang scheme/base
|
||||
|
||||
(module teachpack mzscheme
|
||||
(require "drscheme-test-util.ss"
|
||||
mzlib/class
|
||||
mzlib/file
|
||||
mred
|
||||
framework
|
||||
(prefix fw: framework))
|
||||
(require "drscheme-test-util.ss"
|
||||
scheme/class
|
||||
scheme/path
|
||||
scheme/gui/base
|
||||
(prefix-in fw: framework))
|
||||
|
||||
(provide run-test)
|
||||
(provide run-test)
|
||||
|
||||
(define drs-frame 'not-yet-drs-frame)
|
||||
(define interactions-text 'not-yet-interactions-text)
|
||||
(define drs-frame 'not-yet-drs-frame)
|
||||
(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)
|
||||
(type-in-definitions drs-frame dr-exp)
|
||||
(fw:test:menu-select "Language" "Clear All Teachpacks")
|
||||
|
|
@ -58,8 +57,8 @@
|
|||
full-expectation
|
||||
got)))))
|
||||
|
||||
;; there are no more errors when the teachpack is loaded (for now...)
|
||||
(define (test-bad/load-teachpack tp-exp expected-error)
|
||||
;; 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
|
||||
|
|
@ -89,7 +88,7 @@
|
|||
(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)
|
||||
(define (test-bad/execute-teachpack tp-exp expected)
|
||||
(fw:test:menu-select "Language" "Clear All Teachpacks")
|
||||
(let ([tp-name (normal-case-path
|
||||
(normalize-path
|
||||
|
|
@ -134,7 +133,7 @@
|
|||
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n"
|
||||
tp-exp error)]))))
|
||||
|
||||
(define (generic-tests)
|
||||
(define (generic-tests)
|
||||
(test-good-teachpack
|
||||
(list
|
||||
`(module ,(string->symbol (format good-teachpack-name 0)) mzscheme))
|
||||
|
|
@ -158,12 +157,12 @@
|
|||
"(+ not-a-primitive1 not-a-primitive2)"
|
||||
"3"))
|
||||
|
||||
(define (good-tests)
|
||||
(define (good-tests)
|
||||
(set-language-level! '("How to Design Programs" "Beginning Student"))
|
||||
(do-execute drs-frame)
|
||||
(generic-tests))
|
||||
|
||||
(define (bad-tests)
|
||||
(define (bad-tests)
|
||||
(set-language-level! '("How to Design Programs" "Beginning Student"))
|
||||
|
||||
(test-bad/execute-teachpack
|
||||
|
|
@ -174,7 +173,7 @@
|
|||
`(module teachpack-tmp mzscheme (car))
|
||||
"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
|
||||
(lambda (port)
|
||||
(apply string-append
|
||||
|
|
@ -185,8 +184,8 @@
|
|||
(list* l " " (loop)))))))
|
||||
'text))
|
||||
|
||||
;; doesn't test graphing.ss teachpack
|
||||
(define (test-built-in-teachpacks)
|
||||
;; doesn't test graphing.ss teachpack
|
||||
(define (test-built-in-teachpacks)
|
||||
(clear-definitions drs-frame)
|
||||
(type-in-definitions drs-frame "1")
|
||||
(let* ([test-teachpack
|
||||
|
|
@ -224,7 +223,7 @@
|
|||
(test-teachpacks (list (build-path teachpack-dir "2htdp")
|
||||
(build-path teachpack-dir "htdp")))))
|
||||
|
||||
(define (find-leftmost-choice frame)
|
||||
(define (find-leftmost-choice frame)
|
||||
(let loop ([p frame])
|
||||
(cond
|
||||
[(is-a? p list-box%) p]
|
||||
|
|
@ -232,9 +231,14 @@
|
|||
(ormap loop (send p get-children))]
|
||||
[else #f])))
|
||||
|
||||
(define (run-test)
|
||||
(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)))
|
||||
(test-built-in-teachpacks))
|
||||
|
||||
(let ()
|
||||
(fire-up-drscheme)
|
||||
(thread (λ () (run-test) (exit)))
|
||||
(yield (make-semaphore)))
|
||||
|
|
|
|||
|
|
@ -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)]))))
|
||||
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define name "Test Suites")
|
||||
(define tools '(("tool.ss" "drscheme") ("time-keystrokes.ss" "drscheme")))
|
||||
(define tool-names '("DrScheme Test Suites" "Time Keystrokes"))
|
||||
(define tools '(("time-keystrokes.ss" "drscheme")))
|
||||
(define tool-names '("Time Keystrokes"))
|
||||
|
||||
(define compile-omit-paths
|
||||
'("2htdp"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user