From 482a446db188c25a56fea07e3b58f4b7e03fa029 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 24 Apr 2015 21:31:29 -0500 Subject: [PATCH] add a more cover-friendly mode to the framework test suite --- gui-test/framework/tests/debug.rkt | 11 +- gui-test/framework/tests/test-suite-utils.rkt | 438 +++++++++++------- 2 files changed, 273 insertions(+), 176 deletions(-) diff --git a/gui-test/framework/tests/debug.rkt b/gui-test/framework/tests/debug.rkt index dc3332df..c53ff4f8 100644 --- a/gui-test/framework/tests/debug.rkt +++ b/gui-test/framework/tests/debug.rkt @@ -1,6 +1,7 @@ #lang racket/base (require (for-syntax racket/base)) -(provide debug-printf debug-when) +(provide debug-printf debug-when + exn->str) (module test racket/base) @@ -31,3 +32,11 @@ (syntax-case stx () [(_ flag fmt x ...) #'(debug-when flag (printf ">> ~a: ~a" 'flag (format fmt x ...)))])) + + +(define (exn->str exn) + (let ([sp (open-output-string)]) + (parameterize ([current-error-port sp]) + ((error-display-handler) (exn-message exn) exn)) + (get-output-string sp))) + diff --git a/gui-test/framework/tests/test-suite-utils.rkt b/gui-test/framework/tests/test-suite-utils.rkt index b5daf8cb..db29b3a7 100644 --- a/gui-test/framework/tests/test-suite-utils.rkt +++ b/gui-test/framework/tests/test-suite-utils.rkt @@ -1,11 +1,7 @@ #lang racket/base (require (only-in mzscheme fluid-let) - launcher - racket/system - racket/tcp - racket/pretty - compiler/find-exe + (for-syntax racket/base) "debug.rkt") (provide @@ -54,182 +50,280 @@ (define failed-tests null) (define number-of-tests 0) -(define-struct eof-result ()) +(module local-namespace racket/base + (require racket/gui/base) + (provide send-sexp-to-mred + queue-sexp-to-mred + eof-result? + shutdown-listener shutdown-mred mred-running? + load-framework-automatically) -(define load-framework-automatically? #t) + (define ns? #f) + (define eventspace (make-eventspace)) + + (define (send-sexp-to-mred sexp) + (unless ns? + (namespace-require 'framework) + (namespace-require 'racket/gui/base) + (set! ns? #t)) + + (define c (make-channel)) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (channel-put + c + (eval sexp))))) + (channel-get c)) -(define initial-port 6012) -(define port-filename - (build-path (find-system-path 'temp-dir) - "framework-tests-receive-sexps-port.rkt")) + (define queue-sexp-to-mred send-sexp-to-mred) -(unless (file-exists? port-filename) - (call-with-output-file port-filename - (lambda (port) (write initial-port port)))) + (define (eof-result? x) + (error 'local-namespace + (string-append + "cannot use eof-result? with the local-namespace setup" + " (so probably it should be improved)"))) -(define listener - (let loop ([port (call-with-input-file port-filename read)]) - (let ([l (with-handlers ([exn:fail? (lambda (_) #f)]) - (tcp-listen port))]) - (if l - (begin (debug-printf mz-tcp "listening to ~a\n" port) - (call-with-output-file port-filename - (lambda (p) (write port p)) - #:exists 'truncate) - l) - (begin (debug-printf mz-tcp " tcp-listen failed for port ~a\n" port) - (loop (add1 port))))))) + (define (shutdown-listener) + (error 'local-namespace + (string-append + "cannot use shutdown-listener with the local-namespace setup" + " (maybe it could be improved -- not clear)"))) + (define (shutdown-mred) + (error 'local-namespace + (string-append + "cannot use shutdown-mred with the local-namespace setup" + " (maybe it could be improved -- not clear)"))) + + (define (mred-running? x) + (error 'local-namespace + (string-append + "cannot use mred-running? with the local-namespace setup" + " (so probably it should be improved)"))) + + (define load-framework-automatically? #t) + (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?))) + (error 'local-namespace + (string-append + "cannot change load-framework-automatically with the local-namespace setup" + " (so probably it should be improved)")))] + [() load-framework-automatically?]))) + +(module remote-process racket/base + (require compiler/find-exe + racket/system + "debug.rkt" + racket/tcp + racket/pretty) + (provide send-sexp-to-mred + queue-sexp-to-mred + eof-result? + shutdown-listener shutdown-mred mred-running? + load-framework-automatically) + + (define in-port #f) + (define out-port #f) + (define load-framework-automatically? #t) + + (define initial-port 6012) + (define port-filename + (build-path (find-system-path 'temp-dir) + "framework-tests-receive-sexps-port.rkt")) + + (unless (file-exists? port-filename) + (call-with-output-file port-filename + (lambda (port) (write initial-port port)))) -(define in-port #f) -(define out-port #f) + (define listener + (let loop ([port (call-with-input-file port-filename read)]) + (let ([l (with-handlers ([exn:fail? (lambda (_) #f)]) + (tcp-listen port))]) + (if l + (begin (debug-printf mz-tcp "listening to ~a\n" port) + (call-with-output-file port-filename + (lambda (p) (write port p)) + #:exists 'truncate) + l) + (begin (debug-printf mz-tcp " tcp-listen failed for port ~a\n" port) + (loop (add1 port))))))) -(define (restart-mred) - (shutdown-mred) - (thread - (lambda () - (define racket-bin (find-exe)) - (unless (system* - racket-bin - (path->string - (collection-file-path "framework-test-engine.rkt" "framework" "tests"))) - (eprintf "starting gracket failed; used path ~s\n" - racket-bin)))) - (debug-printf mz-tcp "accepting listener\n") - (let-values ([(in out) (tcp-accept listener)]) - (set! in-port in) - (set! out-port out)) - (when load-framework-automatically? - (queue-sexp-to-mred - '(begin (eval '(require framework)) - (eval '(require framework/tests/private/gui)))))) - -(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 () + (define-struct eof-result ()) + + (define (restart-mred) (shutdown-mred) - (debug-printf mz-tcp "closing listener\n") - (tcp-close listener))) + (thread + (lambda () + (define racket-bin (find-exe)) + (unless (system* + racket-bin + (path->string + (collection-file-path "framework-test-engine.rkt" "framework" "tests"))) + (eprintf "starting gracket failed; used path ~s\n" + racket-bin)))) + (debug-printf mz-tcp "accepting listener\n") + (let-values ([(in out) (tcp-accept listener)]) + (set! in-port in) + (set! out-port out)) + (when load-framework-automatically? + (queue-sexp-to-mred + '(begin (eval '(require framework)) + (eval '(require framework/tests/private/gui)))))) + + (define shutdown-mred + (lambda () + (when (and in-port + out-port) + (with-handlers ([exn:fail? (lambda (x) (void))]) + (close-output-port out-port)) + (with-handlers ([exn:fail? (lambda (x) (void))]) + (close-input-port in-port)) + (set! in-port #f) + (set! in-port #f)))) + + (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-mred - (lambda () - (when (and in-port - out-port) - (with-handlers ([exn:fail? (lambda (x) (void))]) - (close-output-port out-port)) - (with-handlers ([exn:fail? (lambda (x) (void))]) - (close-input-port in-port)) - (set! in-port #f) - (set! in-port #f)))) + (namespace-require 'racket) ;; in order to make the eval below work right. -(define (mred-running?) - (if (char-ready? in-port) - (not (eof-object? (peek-char in-port))) - #t)) + (define (send-sexp-to-mred sexp) + (let/ec k + (let ([show-text + (lambda (sexp) + (debug-when messages + (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)) + (show-text sexp) + (with-handlers ([exn:fail? + (lambda (x) + (cond + ;; this means that gracket was closed + ;; so we can restart it and try again. + [(tcp-error? x) + (restart-mred) + (write sexp out-port) + (newline out-port) + (flush-output out-port)] + [else (raise x)]))]) + (write sexp out-port) + (newline out-port) + (flush-output out-port)) + (let ([answer + (with-handlers ([exn:fail? + (lambda (x) + (if (tcp-error? x);; assume tcp-error means app closed + eof + (list 'cant-read + (string-append + (exn->str 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))]) + (show-text answer) + (unless (or (eof-object? answer) + (and (list? answer) + (= 2 (length answer)) + (memq (car answer) + '(error last-error cant-read normal)))) + (error 'send-sexp-to-mred "unpected result from gracket: ~s\n" answer)) + (if (eof-object? answer) + (raise (make-eof-result)) + (case (car answer) + [(error) + (error 'send-sexp-to-mred "gracket raised \"~a\"" (list-ref answer 1))] + [(last-error) + (error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (list-ref answer 1))] + [(cant-read) (error 'mred/cant-parse (list-ref answer 1))] + [(normal) + (eval (list-ref answer 1))])))))) -(define queue-sexp-to-mred - (lambda (sexp) - (send-sexp-to-mred - `(let ([thunk (lambda () ,sexp)] ;; low tech hygiene - [c (make-channel)]) - (queue-callback (lambda () (channel-put c (with-handlers ((exn:fail? (λ (x) (list 'exn x)))) (list 'normal (thunk)))))) - (let ([res (channel-get c)]) - (if (eq? (list-ref res 0) 'normal) - (list-ref res 1) - (raise (list-ref res 1)))))))) + (define queue-sexp-to-mred + (lambda (sexp) + (send-sexp-to-mred + `(let ([thunk (lambda () ,sexp)] ;; low tech hygiene + [c (make-channel)]) + (queue-callback (λ () + (channel-put c + (with-handlers ((exn:fail? (λ (x) (list 'exn x)))) + (list 'normal (thunk)))))) + (let ([res (channel-get c)]) + (if (eq? (list-ref res 0) 'normal) + (list-ref res 1) + (raise (list-ref res 1)))))))) -(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 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 shutdown-listener + (lambda () + (shutdown-mred) + (debug-printf mz-tcp "closing listener\n") + (tcp-close listener))) + + (define (mred-running?) + (if (char-ready? in-port) + (not (eof-object? (peek-char in-port))) + #t))) -(namespace-require 'racket) ;; in order to make the eval below work right. -(define (send-sexp-to-mred sexp) - (let/ec k - (let ([show-text - (lambda (sexp) - (debug-when messages - (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)) - (debug-printf messages " ~a // ~a: sending to framework side to eval:\n" - section-name test-name) - (show-text sexp) - (with-handlers ([exn:fail? - (lambda (x) - (cond - ;; this means that gracket was closed - ;; so we can restart it and try again. - [(tcp-error? x) - (restart-mred) - (write sexp out-port) - (newline out-port) - (flush-output out-port)] - [else (raise x)]))]) - (write sexp out-port) - (newline out-port) - (flush-output out-port)) - (let ([answer - (with-handlers ([exn:fail? - (lambda (x) - (if (tcp-error? x);; assume tcp-error means app closed - eof - (list 'cant-read - (string-append - (exn->str 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))]) - (debug-printf messages " ~a // ~a: received from gracket:\n" section-name test-name) - (show-text answer) - (unless (or (eof-object? answer) - (and (list? answer) - (= 2 (length answer)) - (memq (car answer) - '(error last-error cant-read normal)))) - (error 'send-sexp-to-mred "unpected result from gracket: ~s\n" answer)) - (if (eof-object? answer) - (raise (make-eof-result)) - (case (car answer) - [(error) - (error 'send-sexp-to-mred "gracket raised \"~a\"" (list-ref answer 1))] - [(last-error) - (error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (list-ref answer 1))] - [(cant-read) (error 'mred/cant-parse (list-ref answer 1))] - [(normal) - (eval (list-ref answer 1))])))))) +(require (prefix-in r: (submod "." remote-process))) +(require (prefix-in l: (submod "." local-namespace))) +(define use-local? (getenv "PLTGUIUSELOCAL")) +(define-syntax (choose stx) + (syntax-case stx () + [(_) #'(void)] + [(_ n ns ...) + (let () + (define (id-append p) + (datum->syntax stx (string->symbol (format "~a~a" p (syntax-e #'n))))) + (with-syntax ([l:n (id-append 'l:)] + [r:n (id-append 'r:)]) + #'(begin + (define n (if use-local? l:n r:n)) + (choose ns ...))))])) + +(choose send-sexp-to-mred + queue-sexp-to-mred + eof-result? + shutdown-listener shutdown-mred mred-running? + load-framework-automatically) (define test (case-lambda @@ -265,12 +359,6 @@ [(continue) (void)] [else (jump)])))))])) -(define (exn->str exn) - (let ([sp (open-output-string)]) - (parameterize ([current-error-port sp]) - ((error-display-handler) (exn-message exn) exn)) - (get-output-string sp))) - (define (wait-for/wrapper wrapper sexp) (let ([timeout 10] [pause-time 1/2])