diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 076179fa..13bf2abd 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -1,3 +1,5 @@ +`(load.ss) + `(#| Framework Test Suite Overview diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index f6da8ad4..40a58e78 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -1,142 +1,31 @@ -(let ([pred (lambda (x) (void? x))] - [old-load-framework-automatically? (load-framework-automatically)]) +(module load mzscheme + (require "test-suite-utils.ss") + + (define old-load-framework-automatically? (load-framework-automatically)) + + (define (test/load file exp) + (test + (string->symbol file) + void? + `(parameterize ([current-namespace (make-namespace 'mred)]) + (require (lib ,file "framework")) + ,exp + (void)))) (load-framework-automatically #f) - (test - 'guiutilss.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "guiutilss.ss" "framework") - (global-defined-value 'framework:gui-utils^) - (void))) - - (test - 'guiutils.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "guiutils.ss" "framework") - (global-defined-value 'gui-utils:read-snips/chars-from-text) - (void))) + (test/load "prefs-file-unit.ss" 'framework:preferences@) + (test/load "prefs-file.ss" 'get-preferences-filename) - (test - 'guiutilsr.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "guiutilss.ss" "framework") - (eval - '(invoke-unit/sig - (compound-unit/sig - (import) - (link [m : mred^ (mred@)] - [g : framework:gui-utils^ ((require-library "guiutilsr.ss" "framework") m)]) - (export)))) - (void))) + (test/load "gui-utils-unit.ss" 'framework:gui-utils@) + (test/load "gui-utils.ss" 'next-untitled-name) - - (test - 'macro.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "macro.ss" "framework") - (global-defined-value 'mixin) - (void))) - (test - 'tests.ss - (lambda (x) x) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "tests.ss" "framework") - (unit/sig? (require-library "keys.ss" "framework")))) - (test - 'testr.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "tests.ss" "framework") - (eval - '(define-values/invoke-unit/sig - ((unit test : framework:test^)) - (compound-unit/sig - (import) - (link [mred : mred^ (mred@)] - [keys : framework:keys^ ((require-library "keys.ss" "framework"))] - [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)]) - (export (unit test))))) - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (void))) - (test - 'test.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "test.ss" "framework") - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (void))) + (test/load "test-unit.ss" 'framework:test@) + (test/load "test.ss" 'test:run-interval) - (test - 'frameworkp.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "frameworks.ss" "framework") - (require-library "file.ss") - (eval - '(define-values/invoke-unit/sig - framework^ - (compound-unit/sig - (import) - (link [mred : mred^ (mred@)] - [core : mzlib:core^ ((require-library "corer.ss"))] - [pf : framework:prefs-file^ - ((let ([tf (make-temporary-file)]) - (unit/sig framework:prefs-file^ (import) - (define (get-preferences-filename) tf))))] - [framework : framework^ ((require-library "frameworkp.ss" "framework") - core mred pf)]) - (export (open framework))))) - (global-defined-value 'preferences:get) - (void))) + (test/load "macro.ss" '(mixin () () ())) - (test - 'frameworkr.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "frameworks.ss" "framework") - (eval - '(define-values/invoke-unit/sig - framework^ - (compound-unit/sig - (import) - (link [mred : mred^ (mred@)] - [core : mzlib:core^ ((require-library "corer.ss"))] - [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)]) - (export (open framework))))) - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (global-defined-value 'frame:basic-mixin) - (global-defined-value 'editor:basic-mixin) - (global-defined-value 'exit:exit) - (void))) - (test - 'framework.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "framework.ss" "framework") - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (global-defined-value 'frame:basic-mixin) - (global-defined-value 'editor:basic-mixin) - (global-defined-value 'exit:exit) - (void))) - (test - 'framework.ss/gen - (lambda (x) x) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "pretty.ss") - (let* ([op ((global-defined-value 'pretty-print-print-line))] - [np (lambda x (apply op x))]) - ((global-defined-value 'pretty-print-print-line) np) - (require-library "framework.ss" "framework") - (eq? np ((global-defined-value 'pretty-print-print-line)))))) + (test/load "framework-unit.ss" 'framework@) + (test/load "framework.ss" 'frame:basic-mixin) (load-framework-automatically old-load-framework-automatically?)) - diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index 437e5e3b..888ba074 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -1,395 +1,108 @@ (module main mzscheme (require (lib "launcher.ss" "launcher") (lib "cmdline.ss") - (lib "etc.ss") - (lib "list.ss") - (lib "string.ss") - (lib "file.ss") (lib "unitsig.ss") - (lib "class.ss") + "test-suite-utils.ss" (lib "guis.ss" "tests" "utils")) + (provide + only-these-tests + section-name + section-jump) + + (define initial-port 6012) + + (define section-jump void) + (define section-name "<>") + (define only-these-tests #f) + (unless (file-exists? (build-path (current-load-relative-directory) "receive-sexps-port.ss")) (call-with-output-file (build-path (current-load-relative-directory) "receive-sexps-port.ss") (lambda (port) - (write 6012 port)))) + (write initial-port port)))) - (define-signature TestSuite^ - ((struct eof-result ()) - load-framework-automatically - shutdown-listener shutdown-mred mred-running? - send-sexp-to-mred queue-sexp-to-mred - test - wait-for-frame + (define preferences-file (build-path (find-system-path 'pref-dir) + (case (system-type) + [(macos) "MrEd Preferences"] + [(windows) "mred.pre"] + [(unix) ".mred.prefs"]))) + (define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)]) + (build-path base (string-append name ".save")))) + - ;; sexp -> void - ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window - wait-for-new-frame - - wait-for)) - - (define-signature internal-TestSuite^ - ((open TestSuite^) - test-name - failed-tests)) - - (define-signature Engine^ - (only-these-tests - section-name - section-jump)) - - (define TestSuite - (unit/sig internal-TestSuite^ - (import (program) - Engine^ - launcher-maker^ - mzlib:pretty-print^ - mzlib:function^) - - (define test-name "<>") - (define failed-tests null) - - (define-struct eof-result ()) - - (define load-framework-automatically? #t) - - (define listener - (let loop () - (let ([port (load-relative "receive-sexps-port.ss")]) - (with-handlers ([(lambda (x) #t) - (lambda (x) - (let ([next (+ port 1)]) - (call-with-output-file (build-path (current-load-relative-directory) - "receive-sexps-port.ss") - (lambda (p) - (write next p)) - 'truncate) - (printf " tcp-listen failed for port ~a, attempting ~a~n" - port next) - (loop)))]) - (tcp-listen port))))) - - (define in-port #f) - (define out-port #f) - - (define restart-mred - (lambda () - (shutdown-mred) - (let-values ([(base _1 _2) (split-path program)]) - ((case (system-type) - [(macos) system*] - [else (lambda (x) (thread (lambda () (system* x))))]) - (mred-program-launcher-path "Framework Test Engine"))) - (let-values ([(in out) (tcp-accept listener)]) - (set! in-port in) - (set! out-port out)) - (when load-framework-automatically? - (queue-sexp-to-mred - `(begin - (require (lib "framework.ss" "framework") - (lib "gui.ss" "tests" "utils"))))))) - - (define load-framework-automatically - (case-lambda - [(new-load-framework-automatically?) - (unless (eq? (not (not new-load-framework-automatically?)) - load-framework-automatically?) - (set! load-framework-automatically? (not (not new-load-framework-automatically?))) - (shutdown-mred))] - [() load-framework-automatically?])) - - (define shutdown-listener - (lambda () - (shutdown-mred) - (tcp-close listener))) - - (define shutdown-mred - (lambda () - (when (and in-port - out-port) - (with-handlers ([(lambda (x) #t) (lambda (x) (void))]) - (close-output-port out-port)) - (with-handlers ([(lambda (x) #t) (lambda (x) (void))]) - (close-input-port in-port)) - (set! in-port #f) - (set! in-port #f)))) - - (define mred-running? - (lambda () - (if (char-ready? in-port) - (not (eof-object? (peek-char in-port))) - #t))) - - (define queue-sexp-to-mred - (lambda (sexp) - (send-sexp-to-mred - `(let ([thunk (lambda () ,sexp)] - [sema (make-semaphore 0)]) - (queue-callback (lambda () - (thunk) - (semaphore-post sema))) - (semaphore-wait sema))))) - - (define re:tcp-read-error (regexp "tcp-read:")) - (define re:tcp-write-error (regexp "tcp-write:")) - (define (tcp-error? exn) - (or (regexp-match re:tcp-read-error (exn-message exn)) - (regexp-match re:tcp-write-error (exn-message exn)))) - - (define send-sexp-to-mred - (let ([failed-last-time? #f]) - (lambda (sexp) - (let/ec k - (let ([show-text - (lambda (sexp) - - (parameterize ([pretty-print-print-line - (let ([prompt " "] - [old-liner (pretty-print-print-line)]) - (lambda (ln port ol cols) - (let ([ov (old-liner ln port ol cols)]) - (if ln - (begin (display prompt port) - (+ (string-length prompt) ov)) - ov))))]) - (pretty-print sexp) - (newline)))]) - (unless (and in-port - out-port - (with-handlers ([tcp-error? - (lambda (x) #f)]) - (or (not (char-ready? in-port)) - (not (eof-object? (peek-char in-port)))))) - (restart-mred)) - (printf " ~a // ~a: sending to mred:~n" section-name test-name) - (show-text sexp) - (with-handlers ([(lambda (x) #t) - (lambda (x) - (cond - ;; this means that mred was closed - ;; so we can restart it and try again. - [(tcp-error? x) - (restart-mred) - (write sexp out-port) - (newline out-port)] - [else (raise x)]))]) - (write sexp out-port) - (newline out-port)) - (let ([answer - (with-handlers ([(lambda (x) #t) - (lambda (x) - (if (tcp-error? x);; assume tcp-error means app closed - eof - (list 'cant-read - (string-append - (exn-message x) - "; rest of string: " - (format - "~s" - (apply - string - (let loop () - (if (char-ready? in-port) - (let ([char (read-char in-port)]) - (if (eof-object? char) - null - (cons char (loop)))) - null))))))))]) - (read in-port))]) - (unless (or (eof-object? answer) - (and (list? answer) - (= 2 (length answer)))) - (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) - (if (eof-object? answer) - (raise (make-eof-result)) - (case (car answer) - [(error) - (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] - [(cant-read) (error 'mred/cant-parse (second answer))] - [(normal) - (printf " ~a // ~a: received from mred:~n" section-name test-name) - (show-text (second answer)) - (eval (second answer))])))))))) - - - (define test - (case-lambda - [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)] - [(in-test-name passed? sexp/proc jump) - (fluid-let ([test-name in-test-name]) - (when (or (not only-these-tests) - (memq test-name only-these-tests)) - (let ([failed - (with-handlers ([(lambda (x) #t) - (lambda (x) - (if (exn? x) - (exn-message x) - x))]) - (let ([result - (if (procedure? sexp/proc) - (sexp/proc) - (begin0 (send-sexp-to-mred sexp/proc) - (send-sexp-to-mred ''check-for-errors)))]) - (not (passed? result))))]) - (when failed - (printf "FAILED ~a: ~a~n" failed test-name) - (set! failed-tests (cons (cons section-name test-name) failed-tests)) - (case jump - [(section) (section-jump)] - [(continue) (void)] - [else (jump)])))))])) - - (define (wait-for/wrapper wrapper sexp) - (let ([timeout 10] - [pause-time 1/2]) - (send-sexp-to-mred - (wrapper - `(let ([test (lambda () ,sexp)]) - (let loop ([n ,(/ timeout pause-time)]) - (if (zero? n) - (error 'wait-for - ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) - (unless (test) - (sleep ,pause-time) - (loop (- n 1)))))))))) - - (define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp)) - - (define (wait-for-new-frame sexp) - (wait-for/wrapper - (lambda (w) - `(let ([frame (get-top-level-focus-window)]) - ,sexp - ,w)) - `(not (eq? frame (get-top-level-focus-window))))) - - (define (wait-for-frame name) - (wait-for `(let ([win (get-top-level-focus-window)]) - (and win - (string=? (send win get-label) ,name))))))) - - (define Engine - (unit/sig Engine^ - (import (argv) - internal-TestSuite^ - mzlib:command-line^ - mzlib:function^ - mzlib:file^ - mzlib:string^ - mzlib:pretty-print^) - - (define section-jump void) - (define section-name "<>") - (define only-these-tests #f) - - (define preferences-file (build-path (find-system-path 'pref-dir) - (case (system-type) - [(macos) "MrEd Preferences"] - [(windows) "mred.pre"] - [(unix) ".mred.prefs"]))) - (define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)]) - (build-path base (string-append name ".save")))) + (with-handlers ([(lambda (x) #f) + (lambda (x) (display (exn-message x)) (newline))]) + (let* ([all-files (map symbol->string (load-relative "README"))] + [all? #f] + [files-to-process null] + [command-line-flags + `((once-each + [("-a" "--all") + ,(lambda (flag) + (set! all? #t)) + ("Run all of the tests")]) + (multi + [("-o" "--only") + ,(lambda (flag _only-these-tests) + (set! only-these-tests (cons (string->symbol _only-these-tests) + (or only-these-tests null)))) + ("Only run test named " "test-name")]))]) + (let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")] + [parsed-argv (if (equal? argv (vector)) + (if (file-exists? saved-command-line-file) + (begin + (let ([result (call-with-input-file saved-command-line-file read)]) + (printf "reusing command-line arguments: ~s~n" result) + result)) + (vector)) + argv)]) + (parse-command-line "framework-test" parsed-argv command-line-flags + (lambda (collected . files) + (set! files-to-process (if (or all? (null? files)) all-files files))) + `("Names of the tests; defaults to all tests")) + (call-with-output-file saved-command-line-file + (lambda (port) + (write parsed-argv port)) + 'truncate)) - (with-handlers ([(lambda (x) #f) - (lambda (x) (display (exn-message x)) (newline))]) - (let* ([all-files (map symbol->string (load-relative "README"))] - [all? #f] - [files-to-process null] - [command-line-flags - `((once-each - [("-a" "--all") - ,(lambda (flag) - (set! all? #t)) - ("Run all of the tests")]) - (multi - [("-o" "--only") - ,(lambda (flag _only-these-tests) - (set! only-these-tests (cons (string->symbol _only-these-tests) - (or only-these-tests null)))) - ("Only run test named " "test-name")]))]) - - (let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")] - [parsed-argv (if (equal? argv (vector)) - (if (file-exists? saved-command-line-file) - (begin - (let ([result (call-with-input-file saved-command-line-file read)]) - (printf "reusing command-line arguments: ~s~n" result) - result)) - (vector)) - argv)]) - (parse-command-line "framework-test" parsed-argv command-line-flags - (lambda (collected . files) - (set! files-to-process (if (or all? (null? files)) all-files files))) - `("Names of the tests; defaults to all tests")) - (call-with-output-file saved-command-line-file - (lambda (port) - (write parsed-argv port)) - 'truncate)) - - - (when (file-exists? preferences-file) - (printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) - (if (file-exists? old-preferences-file) - (printf " backup preferences file exists, using that one~n") - (begin (copy-file preferences-file old-preferences-file) - (printf " saved preferences file~n")))) - - (for-each (lambda (x) - (when (member x all-files) - (shutdown-mred) - (let/ec k - (fluid-let ([section-name x] - [section-jump k]) - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (printf "~a~n" (if (exn? exn) (exn-message exn) exn)))]) - (printf "beginning ~a test suite~n" x) - - (invoke-unit/sig - (eval - `(unit/sig () - (import TestSuite^ - mzlib:function^ - mzlib:file^ - mzlib:string^ - mzlib:pretty-print^) - (include ,x))) - TestSuite^ - mzlib:function^ - mzlib:file^ - mzlib:string^ - mzlib:pretty-print^) - (printf "PASSED ~a test suite~n" x)))))) - files-to-process))) - - (printf " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file) + (when (file-exists? preferences-file) - (unless (file-exists? old-preferences-file) - (error 'framework-test "lost preferences file backup!")) - (delete-file preferences-file) - (copy-file old-preferences-file preferences-file) - (delete-file old-preferences-file)) - (printf " restored preferences file~n") + (printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) + (if (file-exists? old-preferences-file) + (printf " backup preferences file exists, using that one~n") + (begin (copy-file preferences-file old-preferences-file) + (printf " saved preferences file~n")))) + + (for-each (lambda (x) + (when (member x all-files) + (shutdown-mred) + (let/ec k + (fluid-let ([section-name x] + [section-jump k]) + (with-handlers ([(lambda (x) #t) + (lambda (exn) + (printf "~a~n" (if (exn? exn) (exn-message exn) exn)))]) + (printf "beginning ~a test suite~n" x) - (shutdown-listener) + (eval `(require ,x)) + + (printf "PASSED ~a test suite~n" x)))))) + files-to-process))) - (unless (null? failed-tests) - (printf "FAILED tests:~n") - (for-each (lambda (failed-test) - (printf " ~a // ~a~n" (car failed-test) (cdr failed-test))) - failed-tests)))) + (printf " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file) + (when (file-exists? preferences-file) + (unless (file-exists? old-preferences-file) + (error 'framework-test "lost preferences file backup!")) + (delete-file preferences-file) + (copy-file old-preferences-file preferences-file) + (delete-file old-preferences-file)) + (printf " restored preferences file~n") + (shutdown-listener) - (invoke-unit/sig - (compound-unit/sig - (import (P : (program)) - (A : (argv)) - [launcher : launcher-maker^]) - (link - [T : internal-TestSuite^ (TestSuite P E launcher)] - [E : Engine^ (Engine A T M)]) - (export)) - (program) - (argv) - launcher-maker^)) \ No newline at end of file + (unless (null? failed-tests) + (printf "FAILED tests:~n") + (for-each (lambda (failed-test) + (printf " ~a // ~a~n" (car failed-test) (cdr failed-test))) + failed-tests))) \ No newline at end of file diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss new file mode 100644 index 00000000..f56c7c52 --- /dev/null +++ b/collects/tests/framework/test-suite-utils.ss @@ -0,0 +1,242 @@ +(module test-suite-utils mzscheme + (require (lib "launcher.ss" "launcher") + (lib "pretty.ss") + (lib "list.ss")) + + (provide + test-name + failed-tests + (struct eof-result ()) + load-framework-automatically + shutdown-listener shutdown-mred mred-running? + send-sexp-to-mred queue-sexp-to-mred + test + wait-for-frame + + ;; sexp -> void + ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window + wait-for-new-frame + + wait-for) + + (define test-name "<>") + (define failed-tests null) + + (define-struct eof-result ()) + + (define load-framework-automatically? #t) + + (define listener + (let loop () + (let ([port (load-relative "receive-sexps-port.ss")]) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (let ([next (+ port 1)]) + (call-with-output-file (build-path (current-load-relative-directory) + "receive-sexps-port.ss") + (lambda (p) + (write next p)) + 'truncate) + (printf " tcp-listen failed for port ~a, attempting ~a~n" + port next) + (loop)))]) + (tcp-listen port))))) + + (define in-port #f) + (define out-port #f) + + (define restart-mred + (lambda () + (shutdown-mred) + (let-values ([(base _1 _2) (split-path program)]) + ((case (system-type) + [(macos) system*] + [else (lambda (x) (thread (lambda () (system* x))))]) + (mred-program-launcher-path "Framework Test Engine"))) + (let-values ([(in out) (tcp-accept listener)]) + (set! in-port in) + (set! out-port out)) + (when load-framework-automatically? + (queue-sexp-to-mred + `(begin + (require (lib "framework.ss" "framework") + (lib "gui.ss" "tests" "utils"))))))) + + (define load-framework-automatically + (case-lambda + [(new-load-framework-automatically?) + (unless (eq? (not (not new-load-framework-automatically?)) + load-framework-automatically?) + (set! load-framework-automatically? (not (not new-load-framework-automatically?))) + (shutdown-mred))] + [() load-framework-automatically?])) + + (define shutdown-listener + (lambda () + (shutdown-mred) + (tcp-close listener))) + + (define shutdown-mred + (lambda () + (when (and in-port + out-port) + (with-handlers ([(lambda (x) #t) (lambda (x) (void))]) + (close-output-port out-port)) + (with-handlers ([(lambda (x) #t) (lambda (x) (void))]) + (close-input-port in-port)) + (set! in-port #f) + (set! in-port #f)))) + + (define mred-running? + (lambda () + (if (char-ready? in-port) + (not (eof-object? (peek-char in-port))) + #t))) + + (define queue-sexp-to-mred + (lambda (sexp) + (send-sexp-to-mred + `(let ([thunk (lambda () ,sexp)] + [sema (make-semaphore 0)]) + (queue-callback (lambda () + (thunk) + (semaphore-post sema))) + (semaphore-wait sema))))) + + (define re:tcp-read-error (regexp "tcp-read:")) + (define re:tcp-write-error (regexp "tcp-write:")) + (define (tcp-error? exn) + (or (regexp-match re:tcp-read-error (exn-message exn)) + (regexp-match re:tcp-write-error (exn-message exn)))) + + (define send-sexp-to-mred + (let ([failed-last-time? #f]) + (lambda (sexp) + (let/ec k + (let ([show-text + (lambda (sexp) + + (parameterize ([pretty-print-print-line + (let ([prompt " "] + [old-liner (pretty-print-print-line)]) + (lambda (ln port ol cols) + (let ([ov (old-liner ln port ol cols)]) + (if ln + (begin (display prompt port) + (+ (string-length prompt) ov)) + ov))))]) + (pretty-print sexp) + (newline)))]) + (unless (and in-port + out-port + (with-handlers ([tcp-error? + (lambda (x) #f)]) + (or (not (char-ready? in-port)) + (not (eof-object? (peek-char in-port)))))) + (restart-mred)) + (printf " ~a // ~a: sending to mred:~n" section-name test-name) + (show-text sexp) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (cond + ;; this means that mred was closed + ;; so we can restart it and try again. + [(tcp-error? x) + (restart-mred) + (write sexp out-port) + (newline out-port)] + [else (raise x)]))]) + (write sexp out-port) + (newline out-port)) + (let ([answer + (with-handlers ([(lambda (x) #t) + (lambda (x) + (if (tcp-error? x);; assume tcp-error means app closed + eof + (list 'cant-read + (string-append + (exn-message x) + "; rest of string: " + (format + "~s" + (apply + string + (let loop () + (if (char-ready? in-port) + (let ([char (read-char in-port)]) + (if (eof-object? char) + null + (cons char (loop)))) + null))))))))]) + (read in-port))]) + (unless (or (eof-object? answer) + (and (list? answer) + (= 2 (length answer)))) + (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) + (if (eof-object? answer) + (raise (make-eof-result)) + (case (car answer) + [(error) + (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] + [(cant-read) (error 'mred/cant-parse (second answer))] + [(normal) + (printf " ~a // ~a: received from mred:~n" section-name test-name) + (show-text (second answer)) + (eval (second answer))])))))))) + + + (define test + (case-lambda + [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)] + [(in-test-name passed? sexp/proc jump) + (fluid-let ([test-name in-test-name]) + (when (or (not only-these-tests) + (memq test-name only-these-tests)) + (let ([failed + (with-handlers ([(lambda (x) #t) + (lambda (x) + (if (exn? x) + (exn-message x) + x))]) + (let ([result + (if (procedure? sexp/proc) + (sexp/proc) + (begin0 (send-sexp-to-mred sexp/proc) + (send-sexp-to-mred ''check-for-errors)))]) + (not (passed? result))))]) + (when failed + (printf "FAILED ~a: ~a~n" failed test-name) + (set! failed-tests (cons (cons section-name test-name) failed-tests)) + (case jump + [(section) (section-jump)] + [(continue) (void)] + [else (jump)])))))])) + + (define (wait-for/wrapper wrapper sexp) + (let ([timeout 10] + [pause-time 1/2]) + (send-sexp-to-mred + (wrapper + `(let ([test (lambda () ,sexp)]) + (let loop ([n ,(/ timeout pause-time)]) + (if (zero? n) + (error 'wait-for + ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) + (unless (test) + (sleep ,pause-time) + (loop (- n 1)))))))))) + + (define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp)) + + (define (wait-for-new-frame sexp) + (wait-for/wrapper + (lambda (w) + `(let ([frame (get-top-level-focus-window)]) + ,sexp + ,w)) + `(not (eq? frame (get-top-level-focus-window))))) + + (define (wait-for-frame name) + (wait-for `(let ([win (get-top-level-focus-window)]) + (and win + (string=? (send win get-label) ,name))))))