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

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)))
+

gui-test/framework/tests/test-suite-utils.rkt

@@ -1,11 +1,7 @@
 #lang racket/base
 
 (require (only-in mzscheme fluid-let)
-         launcher
+         (for-syntax racket/base)
-         racket/system
-         racket/tcp
-         racket/pretty
-         compiler/find-exe
          "debug.rkt")
 
 (provide
@@ -54,20 +50,96 @@
 (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 initial-port 6012)
+  (define (send-sexp-to-mred sexp)
-(define port-filename
+    (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 queue-sexp-to-mred send-sexp-to-mred)
+
+  (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 (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)
+  (unless (file-exists? port-filename)
     (call-with-output-file port-filename
       (lambda (port) (write initial-port port))))
 
-(define listener
+  (define listener
     (let loop ([port (call-with-input-file port-filename read)])
       (let ([l (with-handlers ([exn:fail? (lambda (_) #f)])
                  (tcp-listen port))])
@@ -80,10 +152,9 @@
             (begin (debug-printf mz-tcp "  tcp-listen failed for port ~a\n" port)
                    (loop (add1 port)))))))
 
-(define in-port #f)
+  (define-struct eof-result ())
-(define out-port #f)
   
-(define (restart-mred)
+  (define (restart-mred)
     (shutdown-mred)
     (thread
      (lambda ()
@@ -103,22 +174,7 @@
        '(begin (eval '(require framework))
                (eval '(require framework/tests/private/gui))))))
   
-(define load-framework-automatically
+  (define shutdown-mred
-  (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)
-    (debug-printf mz-tcp "closing listener\n")
-    (tcp-close listener)))
-
-(define shutdown-mred
     (lambda ()
       (when (and in-port
                  out-port)
@@ -129,30 +185,18 @@
         (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:"))
-(define (tcp-error? exn)
-  (or (regexp-match re:tcp-read-error (exn-message exn))
-      (regexp-match re:tcp-write-error (exn-message exn))))
-
-(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)
@@ -174,8 +218,6 @@
                        (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)
@@ -212,7 +254,6 @@
                                                            (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)
@@ -231,6 +272,59 @@
                 [(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 (λ ()
+                            (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 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)))
+
+(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
     [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)]
@@ -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])