suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add a more cover-friendly mode to the framework test suite

Browse Source
This commit is contained in:
Robby Findler 2015-04-24 21:31:29 -05:00
parent 42f50a7c08
commit 482a446db1
2 changed files with 273 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gui-test/framework/tests/debug.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(provide debug-printf debug-when) (provide debug-printf debug-when
exn->str)
(module test racket/base) (module test racket/base)
@ -31,3 +32,11 @@
(syntax-case stx () (syntax-case stx ()
[(_ flag fmt x ...) [(_ flag fmt x ...)
#'(debug-when flag (printf ">> ~a: ~a" 'flag (format 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)))

434
gui-test/framework/tests/test-suite-utils.rkt
View File

@ -1,11 +1,7 @@
#lang racket/base #lang racket/base
(require (only-in mzscheme fluid-let) (require (only-in mzscheme fluid-let)
launcher (for-syntax racket/base)
racket/system
racket/tcp
racket/pretty
compiler/find-exe
"debug.rkt") "debug.rkt")
(provide (provide
@ -54,182 +50,280 @@
(define failed-tests null) (define failed-tests null)
(define number-of-tests 0) (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 initial-port 6012) (define (send-sexp-to-mred sexp)
(define port-filename (unless ns?
(build-path (find-system-path 'temp-dir) (namespace-require 'framework)
"framework-tests-receive-sexps-port.rkt")) (namespace-require 'racket/gui/base)
(set! ns? #t))
(unless (file-exists? port-filename) (define c (make-channel))
(call-with-output-file port-filename (parameterize ([current-eventspace eventspace])
(lambda (port) (write initial-port port)))) (queue-callback
(λ ()
(channel-put
c
(eval sexp)))))
(channel-get c))
(define listener (define queue-sexp-to-mred send-sexp-to-mred)
(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 in-port #f) (define (eof-result? x)
(define out-port #f) (error 'local-namespace
(string-append
"cannot use eof-result? with the local-namespace setup"
" (so probably it should be improved)")))
(define (restart-mred) (define (shutdown-listener)
(shutdown-mred) (error 'local-namespace
(thread (string-append
(lambda () "cannot use shutdown-listener with the local-namespace setup"
(define racket-bin (find-exe)) " (maybe it could be improved -- not clear)")))
(unless (system* (define (shutdown-mred)
racket-bin (error 'local-namespace
(path->string (string-append
(collection-file-path "framework-test-engine.rkt" "framework" "tests"))) "cannot use shutdown-mred with the local-namespace setup"
(eprintf "starting gracket failed; used path ~s\n" " (maybe it could be improved -- not clear)")))
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 (define (mred-running? x)
(case-lambda (error 'local-namespace
[(new-load-framework-automatically?) (string-append
(unless (eq? (not (not new-load-framework-automatically?)) "cannot use mred-running? with the local-namespace setup"
load-framework-automatically?) " (so probably it should be improved)")))
(set! load-framework-automatically? (not (not new-load-framework-automatically?)))
(shutdown-mred))]
[() load-framework-automatically?]))
(define shutdown-listener (define load-framework-automatically? #t)
(lambda () (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 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-struct eof-result ())
(define (restart-mred)
(shutdown-mred) (shutdown-mred)
(debug-printf mz-tcp "closing listener\n") (thread
(tcp-close listener))) (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 (define shutdown-mred
(lambda () (lambda ()
(when (and in-port (when (and in-port
out-port) out-port)
(with-handlers ([exn:fail? (lambda (x) (void))]) (with-handlers ([exn:fail? (lambda (x) (void))])
(close-output-port out-port)) (close-output-port out-port))
(with-handlers ([exn:fail? (lambda (x) (void))]) (with-handlers ([exn:fail? (lambda (x) (void))])
(close-input-port in-port)) (close-input-port in-port))
(set! in-port #f) (set! in-port #f)
(set! in-port #f)))) (set! in-port #f))))
(define (mred-running?) (define load-framework-automatically
(if (char-ready? in-port) (case-lambda
(not (eof-object? (peek-char in-port))) [(new-load-framework-automatically?)
#t)) (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 queue-sexp-to-mred (namespace-require 'racket) ;; in order to make the eval below work right.
(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 re:tcp-read-error (regexp "tcp-read:")) (define (send-sexp-to-mred sexp)
(define re:tcp-write-error (regexp "tcp-write:")) (let/ec k
(define (tcp-error? exn) (let ([show-text
(or (regexp-match re:tcp-read-error (exn-message exn)) (lambda (sexp)
(regexp-match re:tcp-write-error (exn-message exn)))) (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))]))))))
(namespace-require 'racket) ;; in order to make the eval below work right. (define queue-sexp-to-mred
(define (send-sexp-to-mred sexp) (lambda (sexp)
(let/ec k (send-sexp-to-mred
(let ([show-text `(let ([thunk (lambda () ,sexp)] ;; low tech hygiene
(lambda (sexp) [c (make-channel)])
(debug-when messages (queue-callback (λ ()
(parameterize ([pretty-print-print-line (channel-put c
(let ([prompt " "] (with-handlers ((exn:fail? (λ (x) (list 'exn x))))
[old-liner (pretty-print-print-line)]) (list 'normal (thunk))))))
(lambda (ln port ol cols) (let ([res (channel-get c)])
(let ([ov (old-liner ln port ol cols)]) (if (eq? (list-ref res 0) 'normal)
(if ln (list-ref res 1)
(begin (display prompt port) (raise (list-ref res 1))))))))
(+ (string-length prompt) ov))
ov))))]) (define re:tcp-read-error (regexp "tcp-read:"))
(pretty-print sexp) (define re:tcp-write-error (regexp "tcp-write:"))
(newline))))]) (define (tcp-error? exn)
(unless (and in-port (or (regexp-match re:tcp-read-error (exn-message exn))
out-port (regexp-match re:tcp-write-error (exn-message exn))))
(with-handlers ([tcp-error? (lambda (x) #f)])
(or (not (char-ready? in-port)) (define shutdown-listener
(not (eof-object? (peek-char in-port)))))) (lambda ()
(restart-mred)) (shutdown-mred)
(debug-printf messages " ~a // ~a: sending to framework side to eval:\n" (debug-printf mz-tcp "closing listener\n")
section-name test-name) (tcp-close listener)))
(show-text sexp)
(with-handlers ([exn:fail? (define (mred-running?)
(lambda (x) (if (char-ready? in-port)
(cond (not (eof-object? (peek-char in-port)))
;; this means that gracket was closed #t)))
;; so we can restart it and try again.
[(tcp-error? x) (require (prefix-in r: (submod "." remote-process)))
(restart-mred) (require (prefix-in l: (submod "." local-namespace)))
(write sexp out-port) (define use-local? (getenv "PLTGUIUSELOCAL"))
(newline out-port) (define-syntax (choose stx)
(flush-output out-port)] (syntax-case stx ()
[else (raise x)]))]) [(_) #'(void)]
(write sexp out-port) [(_ n ns ...)
(newline out-port) (let ()
(flush-output out-port)) (define (id-append p)
(let ([answer (datum->syntax stx (string->symbol (format "~a~a" p (syntax-e #'n)))))
(with-handlers ([exn:fail? (with-syntax ([l:n (id-append 'l:)]
(lambda (x) [r:n (id-append 'r:)])
(if (tcp-error? x);; assume tcp-error means app closed #'(begin
eof (define n (if use-local? l:n r:n))
(list 'cant-read (choose ns ...))))]))
(string-append
(exn->str x) (choose send-sexp-to-mred
"; rest of string: " queue-sexp-to-mred
(format eof-result?
"~s" shutdown-listener shutdown-mred mred-running?
(apply load-framework-automatically)
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))]))))))
(define test (define test
(case-lambda (case-lambda
@ -265,12 +359,6 @@
[(continue) (void)] [(continue) (void)]
[else (jump)])))))])) [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) (define (wait-for/wrapper wrapper sexp)
(let ([timeout 10] (let ([timeout 10]
[pause-time 1/2]) [pause-time 1/2])