#| add this test: (let () (display "x") (write-special (make-object string-snip% " in: ")) (display "y") (flush-output)) |# (module io mzscheme (require "drscheme-test-util.ss" (lib "gui.ss" "tests" "utils") mzlib/class mzlib/list mzlib/pretty mred framework (lib "text-string-style-desc.ss" "mrlib") (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" ,value-style) prompt)) (check-output "(display 1)" (list (list "1" output-style) prompt)) (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt)) (check-output "(display 1 (current-error-port))" (list (list "1" error-style) prompt)) (check-output "(display 1) (display 1 (current-error-port))" (list (list "1" output-style) (list "1" error-style) prompt)) (check-output "(display 1 (current-error-port)) (display 1)" (list (list "1" error-style) (list "1" output-style) prompt)) (check-output "(display 1) (display 1 (current-error-port)) (display 1)" (list (list "1" output-style) (list "1" error-style) (list "1" output-style) prompt)) (check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))" (list (list "1" error-style) (list "1" output-style) (list "1" error-style) prompt)) (check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))" (list (list "1" output-style) prompt)) (check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))" (list (list "1" output-style) prompt)) (check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))" (list (list "1" error-style) prompt))) (define (long-io/execute-test) (let ([string-port (open-output-string)]) (pretty-print (let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p))))) string-port) (clear-definitions drs-frame) (type-in-definitions drs-frame "(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))") (do-execute drs-frame) (let ([got-output (fetch-output drs-frame)]) (clear-definitions drs-frame) (do-execute drs-frame) (unless (equal? "" (fetch-output drs-frame)) (error 'io.ss "failed long io / execute test (extra io)")) (unless (whitespace-string=? (get-output-string string-port) got-output) (error 'io.ss "failed long io / execute test (output doesn't match)"))))) (define (reading-test) (define (do-input-test program input expected-transcript) (do-execute drs-frame) (type-in-interactions drs-frame program) (let ([before-newline-pos (send interactions-text last-position)]) (type-in-interactions drs-frame (string #\newline)) (wait (λ () ;; the focus moves to the input box, so wait for that. (send interactions-text get-focus-snip)) "input box didn't appear") (type-string input) (wait-for-computation drs-frame) (let ([got-value (fetch-output drs-frame (send interactions-text paragraph-start-position 3) ;; start after test expression (send interactions-text paragraph-end-position (- (send interactions-text last-paragraph) 1)))]) (unless (equal? got-value expected-transcript) (printf "FAILED: expected: ~s~n got: ~s~n program: ~s~n input: ~s~n" expected-transcript got-value program input))))) (clear-definitions drs-frame) (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 # b c)") (do-input-test "(begin (display 1) (read))" "2\n" "12\n2\n") ;; why an extra newline?! (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 # 2 #)") (do-input-test "(write (read))" "()\n" "()\n()") (do-input-test "(begin (write (read)) (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 (wait-for-drscheme-frame)) (define interactions-text (send drs-frame get-interactions-text)) (set-language-level! (list "Pretty Big (includes MrEd and Advanced Student)")) (define (run-test) (output-err-port-checking) ;; must come first ;(long-io/execute-test) (reading-test) ))