drdr-ized the rest of the drscheme test suite
svn: r17945
This commit is contained in:
Robby Findler
parent
8d2f32efed
commit
e74e46d9ca
|
|
@ -1,90 +1,89 @@
|
|||
(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)])
|
||||
(let* ([snips (get-snips text start end)]
|
||||
[str/ann (map snip->str/ann snips)]
|
||||
[joined-str/ann (join-like str/ann)])
|
||||
joined-str/ann)))
|
||||
(provide get-string/style-desc)
|
||||
(require scheme/gui/base
|
||||
scheme/class)
|
||||
|
||||
;; 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])))
|
||||
;; 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))
|
||||
|
||||
;; 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
|
||||
;; 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)
|
||||
;; 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
|
||||
[(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)))))]))])))
|
||||
[(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
|
||||
;; 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)))))]))]))
|
||||
|
|
|
|||
|
|
@ -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,186 +12,191 @@ add this test:
|
|||
|
||||
|#
|
||||
|
||||
(module io mzscheme
|
||||
(require "drscheme-test-util.ss"
|
||||
tests/utils/gui
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mzlib/pretty
|
||||
mred
|
||||
framework
|
||||
mrlib/text-string-style-desc
|
||||
(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)))))
|
||||
(require "drscheme-test-util.ss"
|
||||
tests/utils/gui
|
||||
mzlib/class
|
||||
mzlib/pretty
|
||||
mred
|
||||
mrlib/text-string-style-desc)
|
||||
|
||||
(define (check-output expression expected)
|
||||
(begin
|
||||
(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\")")
|
||||
(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\n got ~s\nfor ~s\n\n"
|
||||
expected
|
||||
got
|
||||
expression)))))
|
||||
|
||||
(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)")
|
||||
(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)))
|
||||
|
||||
(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?!
|
||||
(define (output-style x) (eq? x '|ports out|))
|
||||
(define (error-style x) (eq? x '|ports err|))
|
||||
(define (value-style x) (eq? x '|ports value|))
|
||||
|
||||
(do-input-test "(read-line)" "\n" "\n\"\"")
|
||||
(do-input-test "(read-char)" "\n" "\n#\\newline")
|
||||
(define prompt '("\n> " default-color))
|
||||
|
||||
(do-input-test "(list (read) (printf \"1~n\") (read) (printf \"3~n\"))"
|
||||
"0 2\n"
|
||||
"0 2\n1\n3\n(0 #<void> 2 #<void>)")
|
||||
(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\n" |ports value|)
|
||||
'("> " default-color)))
|
||||
|
||||
(do-input-test "(write (read))"
|
||||
"()\n"
|
||||
"()\n()")
|
||||
(check-output "(display 1)" (list (list "1" output-style) prompt))
|
||||
(check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt))
|
||||
|
||||
(do-input-test "(begin (write (read)) (write (read)))"
|
||||
"(1)\n(2)\n"
|
||||
"(1)\n(1)(2)\n(2)")
|
||||
(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)))
|
||||
|
||||
(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 (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 drs-frame #f)
|
||||
(define interactions-text #f)
|
||||
|
||||
(define (run-test)
|
||||
(set! drs-frame (wait-for-drscheme-frame))
|
||||
(set! interactions-text (send drs-frame get-interactions-text))
|
||||
(set-language-level! (list #rx"Pretty Big"))
|
||||
(output-err-port-checking) ;; must come first
|
||||
;(long-io/execute-test)
|
||||
(reading-test)
|
||||
))
|
||||
(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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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,8 +1043,9 @@ 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"
|
||||
(language) setting-name expression result got)))))
|
||||
(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)
|
||||
(let* ([expression "#!/bin/sh\n1"]
|
||||
|
|
@ -1058,8 +1057,9 @@ 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"
|
||||
(language) expression result got)))))
|
||||
(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)
|
||||
(regexp-replace (regexp
|
||||
|
|
@ -1094,9 +1094,10 @@ 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"
|
||||
line0-expect line1-expect
|
||||
line0-got line1-got)
|
||||
(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,10 +1177,11 @@ 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"
|
||||
(language) option show-sharing pretty?
|
||||
(shorten got)
|
||||
(if (procedure? answer) (answer) answer)))))])
|
||||
(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)))))])
|
||||
|
||||
(clear-definitions drs)
|
||||
(type-in-definitions drs expression)
|
||||
|
|
@ -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,12 +108,13 @@
|
|||
[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"
|
||||
(test-line test)
|
||||
(test-definitions test)
|
||||
(or (test-interactions test) 'no-interactions)
|
||||
(test-result test)
|
||||
text))
|
||||
(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)
|
||||
(test-result test)
|
||||
text))
|
||||
(cond
|
||||
[(eq? (test-error-ranges test) 'dont-test)
|
||||
(void)]
|
||||
|
|
@ -120,11 +122,12 @@
|
|||
(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"
|
||||
(test-line test)
|
||||
(test-definitions test)
|
||||
error-ranges-expected
|
||||
(send interactions-text get-error-ranges))))])))))
|
||||
(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
|
||||
(send interactions-text get-error-ranges))))])))))
|
||||
|
||||
|
||||
(define drs 'not-yet-drs-frame)
|
||||
|
|
|
|||
|
|
@ -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,12 +1184,14 @@ 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"
|
||||
program))]
|
||||
(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"
|
||||
program))]
|
||||
(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)]
|
||||
[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 (srcloc-span error-range))
|
||||
(loc-offset finish)))
|
||||
(printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n"
|
||||
program
|
||||
(and error-range
|
||||
(list (+ (srcloc-position error-range) -1)
|
||||
(+ (srcloc-position error-range) -1 (srcloc-span error-range))))
|
||||
(list (loc-offset start)
|
||||
(loc-offset finish))))))])])
|
||||
(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)
|
||||
(+ (srcloc-position error-range) -1 (srcloc-span error-range))))
|
||||
(list (loc-offset start)
|
||||
(loc-offset finish))))))])])
|
||||
|
||||
; check text for execute test
|
||||
(next-test)
|
||||
|
|
@ -1220,10 +1221,11 @@ 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"
|
||||
program
|
||||
language-cust
|
||||
execute-answer received-execute))
|
||||
(fprintf (current-error-port)
|
||||
"FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n"
|
||||
program
|
||||
language-cust
|
||||
execute-answer received-execute))
|
||||
|
||||
(test:new-window interactions-canvas)
|
||||
|
||||
|
|
@ -1274,9 +1276,10 @@ 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"
|
||||
short-filename
|
||||
program load-answer received-load)))))])
|
||||
(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))
|
||||
(when (file-exists? tmp-load3-filename)
|
||||
(delete-file tmp-load3-filename))
|
||||
|
|
@ -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,240 +1,244 @@
|
|||
#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)
|
||||
(clear-definitions drs-frame)
|
||||
(type-in-definitions drs-frame dr-exp)
|
||||
(fw:test:menu-select "Language" "Clear All Teachpacks")
|
||||
(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")
|
||||
|
||||
(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))))])))])
|
||||
(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)
|
||||
(generic-tests))
|
||||
|
||||
(define (bad-tests)
|
||||
(set-language-level! '("How to Design Programs" "Beginning Student"))
|
||||
(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)))))
|
||||
|
||||
(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])
|
||||
;; 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
|
||||
[(is-a? p list-box%) p]
|
||||
[(is-a? p area-container<%>)
|
||||
(ormap loop (send p get-children))]
|
||||
[else #f])))
|
||||
[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 (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)))
|
||||
(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)
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -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