bcab28e5d2
Removed "info.rkt", since all entries were unused; switched ".ss" to ".rkt" in both real code and tested code (except for the teachpack tests); modernized some tests to use symbolic requires (which would also make it easier to deal with).
198 lines
7.4 KiB
Racket
198 lines
7.4 KiB
Racket
#lang scheme/base
|
|
|
|
#|
|
|
|
|
add this test:
|
|
|
|
(let ()
|
|
(display "x")
|
|
(write-special (make-object string-snip% " in: "))
|
|
(display "y")
|
|
(flush-output))
|
|
|
|
|#
|
|
|
|
(require "drracket-test-util.rkt"
|
|
tests/utils/gui
|
|
mzlib/class
|
|
mzlib/pretty
|
|
mred
|
|
mrlib/text-string-style-desc)
|
|
|
|
(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\n got ~s\nfor ~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))
|
|
|
|
(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)))
|
|
|
|
(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.rkt "failed long io / execute test (extra io)"))
|
|
(unless (whitespace-string=?
|
|
(get-output-string string-port)
|
|
got-output)
|
|
(error 'io.rkt "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)
|
|
|
|
(fire-up-drscheme-and-run-tests
|
|
(λ ()
|
|
(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)))
|
|
|