adjust frame.rkt framework tests to be more drdr friendly

gui-test/framework/tests/README

@@ -48,7 +48,7 @@ signal failures when there aren't any.
   | Each test assumes that the others pass; this may yield strange
   | error messages when one fails.
 
-  - frames: |# frame.rkt #|
+  - frames: frame.rkt    -- now runs directly via raco test.
   - canvases: canvas.rkt -- now runs directly via raco test.
   - texts: |# text.rkt #|
   - pasteboards: |# pasteboard.rkt #|

gui-test/framework/tests/frame.rkt

@@ -1,150 +1,146 @@
 #lang racket/base
 
-  (require "test-suite-utils.rkt")
+(require "private/here-util.rkt"
+         "private/gui.rkt"
+         rackunit
+         racket/class
+         racket/gui/base
+         framework)
 
-  (module test racket/base)
+(define (test-creation name create)
-  
+  (check-true
-  (send-sexp-to-mred '(send (make-object frame:basic%
+   (let ()
-                              "dummy to keep from quitting")
+     (parameterize ([current-eventspace (make-eventspace)])
-                            show #t))
+       (define c (make-channel))
-  
+       (define f #f)
-  (define (test-creation name class-expression . args)
+       (queue-callback
-    (test
+        (λ ()
-     name
+          (set! f (create))
-     (lambda (x) (eq? 'passed x))
+          (send f show #t)
-     (lambda ()
+          (channel-put c (send f get-label))))
-       (let ([frame-label
+       (define frame-label (channel-get c))
-              (queue-sexp-to-mred
+       (wait-for-frame frame-label)
-               `(let ([f (instantiate ,class-expression () ,@args)])
+       (queue-callback (λ () (send f close)))
-                  (send f show #t)
+       #t))
-                  (send f get-label)))])
+   (format "create ~a" name)))
-         (wait-for-frame frame-label)
+
-         (queue-sexp-to-mred
+(define (creation-tests)
-          '(send (get-top-level-focus-window) close))
-         'passed))))
-  
   (test-creation
    'basic%-creation
-   'frame:basic%
+   (λ () (new frame:basic% [label "test"])))
-   '(label "test"))
   (test-creation
    'basic-mixin-creation
-   '(frame:basic-mixin frame%)
+   (λ () (new (frame:focus-table-mixin (frame:basic-mixin frame%)) [label "test"])))
-   '(label "test"))
-  
   (test-creation
    'info-mixin-creation
-   '(frame:info-mixin frame:basic%)
+   (λ () (new (frame:info-mixin frame:basic%)
-   '(label "test"))
+              [label "test"])))
-  
   (test-creation
    'info%-creation
-   'frame:info%
+   (λ () (new frame:info% [label "test"])))
-   '(label "test"))
-  
   (test-creation
    'text-info-mixin-creation
-   '(frame:text-info-mixin frame:info%)
+   (λ () (new (frame:text-info-mixin frame:info%)
-   '(label "test"))
+              [label "test"])))
   (test-creation
    'text-info%-creation
-   'frame:text-info%
+   (λ () (new frame:text-info% [label "test"])))
-   '(label "test"))
-  
   (test-creation
    'pasteboard-info-mixin-creation
-   '(frame:pasteboard-info-mixin frame:info%)
+   (λ () (new (frame:pasteboard-info-mixin frame:info%)
-   '(label "test"))
+              [label "test"])))
-  
   (test-creation
    'pasteboard-info%-creation
-   'frame:pasteboard-info%
+   (λ () (new frame:pasteboard-info% [label "test"])))
-   '(label "test"))
-  
   (test-creation
    'standard-menus%-creation
-   'frame:standard-menus%
+   (λ () (new frame:standard-menus% [label "test"])))
-   '(label "test"))
-  
   (test-creation
    'standard-menus-mixin
-   '(frame:standard-menus-mixin frame:basic%)
+   (λ () (new (frame:standard-menus-mixin frame:basic%) [label "test"])))
-   '(label "test"))
   
   (test-creation
    'text%-creation
-   'frame:text%)
+   (λ () (new frame:text%)))
   (test-creation
    'text-mixin-creation
-   '(frame:text-mixin frame:editor%))
+   (λ () (new (frame:text-mixin frame:editor%))))
   (test-creation
    'text-mixin-creation
-   '(frame:text-mixin frame:editor%))
+   (λ () (new (frame:text-mixin frame:editor%))))
   
   (test-creation
    'searchable%-creation
-   'frame:searchable%)
+   (λ () (new frame:searchable%)))
   (test-creation
    'searchable-mixin
-   '(frame:searchable-mixin frame:text%))
+   (λ () (new (frame:searchable-mixin frame:text%))))
   
   (test-creation
    'pasteboard-mixin-creation
-   '(frame:pasteboard-mixin frame:editor%))
+   (λ () (new (frame:pasteboard-mixin frame:editor%))))
   (test-creation
    'pasteboard-mixin-creation
-   '(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))
+   (λ () (new (frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))))
   (test-creation
    'pasteboard%-creation
-   'frame:pasteboard%)
+   (λ () (new frame:pasteboard%))))
-  
-  (define (test-open name class-expression)
-    (let* ([test-file-contents "test"]
-           [tmp-file-name "framework-tmp"]
-           [tmp-file (collection-file-path tmp-file-name "framework" "tests")])
-      (test
-       name
-       (lambda (x)
-         (when (file-exists? tmp-file)
-           (delete-file tmp-file))
-         (equal? x test-file-contents))
-       (lambda ()
-         (let ([frame-name 
-                (queue-sexp-to-mred
-                 `(let ([frame (new ,class-expression)])
-                    (preferences:set 'framework:file-dialogs 'common)
-                    (send frame show #t)
-                    (send frame get-label)))])
-           (wait-for-frame frame-name)
-           (send-sexp-to-mred
-            `(test:menu-select "File" "Open..."))
-           (wait-for-frame "Open File")
-           (call-with-output-file tmp-file
-             (lambda (port)
-               (display test-file-contents port))
-             #:exists 'truncate)
-           (queue-sexp-to-mred
-            `(send (find-labelled-window "Filename:") focus))
-           (send-sexp-to-mred
-            `(begin ,(case (system-type)
-                       [(macos macosx) `(test:keystroke #\a '(meta))]
-                       [(unix) `(test:keystroke #\a '(meta))]
-                       [(windows) `(test:keystroke #\a '(control))]
-                       [else (error 'file-open-dialog "unknown system type: ~a" (system-type))])
-                    (for-each test:keystroke
-                              (string->list ,(path->string tmp-file)))
-                    (test:keystroke #\return)))
-           (wait-for-frame tmp-file-name)
-           (begin0
-             (queue-sexp-to-mred
-              `(let* ([w (get-top-level-focus-window)])
-                 (send (send w get-editor) get-text)))
-             (send-sexp-to-mred
-              `(test:close-top-level-window (get-top-level-focus-window)))
-             (wait-for-frame frame-name)
-             (queue-sexp-to-mred
-              `(send (get-top-level-focus-window) close))))))))
-  
-  (test-open "frame:searchable open" 'frame:searchable%)
-  (test-open "frame:text open" 'frame:text%)
 
+(define (test-open name cls)
+  (define test-file-contents "test")
+  (check-equal?
+   (let ()
+     (define tmp-file-name "framework-tmp")
+     (define tmp-file (collection-file-path tmp-file-name "framework" "tests"))
+     (call-with-output-file tmp-file
+       (λ (port) (display test-file-contents port))
+       #:exists 'truncate)
+     (preferences:set 'framework:file-dialogs 'common)
+     (parameterize ([current-eventspace (make-eventspace)])
+       (define c (make-channel))
+       (queue-callback
+        (λ ()
+          (define frame (new cls))
+          (send frame show #t)
+          (channel-put c (send frame get-label))))
+       (define frame-name (channel-get c))
+       (wait-for-frame frame-name)
+       (test:menu-select "File" "Open...")
+       (wait-for-frame "Open File")
+       (queue-callback
+        (λ ()
+          (send (find-labelled-window "Filename:") focus)
+          (channel-put c (void))))
+       (channel-get c)
+       (case (system-type)
+         [(macos macosx) (test:keystroke #\a '(meta))]
+         [(unix) (test:keystroke #\a '(meta))]
+         [(windows) (test:keystroke #\a '(control))])
+       (for-each test:keystroke (string->list (path->string tmp-file)))
+       (test:keystroke #\return)
+       (wait-for-frame tmp-file-name)
+       (queue-callback
+        (λ ()
+          (channel-put c (send (send (test:get-active-top-level-window) get-editor) get-text))))
+       (define editor-contents (channel-get c))
+       (test:close-top-level-window (test:get-active-top-level-window))
+       (wait-for-frame frame-name)
+       (queue-callback
+        (λ ()
+          (send (test:get-active-top-level-window) close)))
+       (preferences:set 'framework:file-dialogs 'std) ;; this is not gooD!!!!
+       (error 'ack "need to figure out how to use the hash-based prefs...?")
+       editor-contents))
+   test-file-contents
+   name))
+
+(define (open-tests)
+  (test-open "frame:searchable open" frame:searchable%)
+  (test-open "frame:text open" frame:text%))
+
+(parameterize ([test:use-focus-table #t])
+  (define dummy (make-object frame:basic% "dummy to keep from quitting"))
+  (send dummy show #t)
+  (creation-tests)
+  (open-tests)
+  (send dummy show #f))

gui-test/framework/tests/private/gui.rkt

@@ -1,7 +1,8 @@
 #lang racket/base
 
   (require racket/gui/base
-           racket/class)
+           racket/class
+           framework/test)
   (provide find-labelled-window 
            find-labelled-windows
            whitespace-string=?)
@@ -86,7 +87,7 @@
   ;;;;  may call error, if no control with the label is found
   (define (find-labelled-window label 
                                 [class #f]
-                                [window (get-top-level-focus-window)]
+                                [window (test:get-active-top-level-window)]
                                 [failure (λ ()
                                            (error 'find-labelled-window "no window labelled ~e in ~e~a"
                                                   label
@@ -99,7 +100,7 @@
       [(null? windows) (failure)]
       [else (car windows)]))
  
-  (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)])
+  (define (find-labelled-windows label [class #f] [window (test:get-active-top-level-window)])
     (unless (or (not label)
                 (string? label))
       (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e"