add frame:focus-table-mixin & related things to be able to make drracket

test suites that don't depend on the OS giving any focus messages

original commit: a67f509f90359203463c943e4de90eb5e8a91656

collects/framework/main.rkt

@@ -9,7 +9,12 @@
          framework/framework-unit
          framework/private/sig
          (for-syntax scheme/base)
-         scribble/srcdoc)
+         scribble/srcdoc) 
+
+;; these next two lines do a little dance to make the
+;; require/doc setup work out properly
+(require (prefix-in :: framework/private/focus-table))
+(define frame:lookup-focus-table ::frame:lookup-focus-table)
 
 (require framework/preferences
          framework/test
@@ -709,7 +714,24 @@
             @racket[bitmap% get-loaded-mask]) and @racket['large].}]
     
     Defaults to @racket[#f].})
-
+ 
+ (proc-doc/names
+  frame:lookup-focus-table
+  (->* () (eventspace?) (listof (is-a?/c frame:focus-table<%>)))
+  (()
+   ((eventspace (current-eventspace))))
+  @{Returns a list of the frames in @racket[eventspace], where the first element of the list
+    is the frame with the focus.
+    
+    The order and contents of the list are maintained by
+    the methods in @racket[frame:focus-table-mixin], meaning that the
+    OS-level callbacks that track the focus of individual frames is 
+    ignored.
+    
+    See also @racket[test:use-focus-table] and @racket[test:get-active-top-level-window].
+    
+    })
+ 
  (proc-doc/names
   group:get-the-frame-group
   (-> (is-a?/c group:%))

collects/framework/private/finder.rkt

@@ -1,14 +1,15 @@
 #lang scheme/unit
 
   (require string-constants
+           (prefix-in r: racket/gui/base)
            "sig.rkt"
            "../preferences.rkt"
            mred/mred-sig
            scheme/path)
   
-  
   (import mred^
-          [prefix keymap: framework:keymap^])
+          [prefix keymap: framework:keymap^]
+          [prefix frame: framework:frame^])
   
   (export (rename framework:finder^
                   [-put-file put-file]
@@ -44,7 +45,8 @@
              [name (or (and (string? name) (file-name-from-path name))
                        name)]
              [f (put-file prompt parent-win directory name
-                          (default-extension) style (default-filters))])
+                          (default-extension) style (default-filters)
+                          #:dialog-mixin frame:focus-table-mixin)])
         (and f (or (not filter) (filter-match? filter f filter-msg))
              (let* ([f (normal-case-path (simple-form-path f))]
                     [dir (path-only f)]
@@ -60,6 +62,7 @@
                   #f]
                  [else f]))))))
   
+  (define op (current-output-port))
   (define (*get-file style)
     (lambda ([directory #f]
              [prompt (string-constant select-file)]
@@ -67,7 +70,8 @@
              [filter-msg (string-constant file-wrong-form)]
              [parent-win (dialog-parent-parameter)])
       (let ([f (get-file prompt parent-win directory #f
-                         (default-extension) style (default-filters))])
+                         (default-extension) style (default-filters)
+                         #:dialog-mixin frame:focus-table-mixin)])
         (and f (or (not filter) (filter-match? filter f filter-msg))
              (cond [(directory-exists? f)
                     (message-box (string-constant error)

collects/framework/private/frame.rkt

@@ -9,6 +9,7 @@
          "../preferences.rkt"
          "../gui-utils.rkt"
          "bday.rkt"
+         framework/private/focus-table
          mrlib/close-icon
          mred/mred-sig
          scheme/path)
@@ -131,6 +132,26 @@
                    editing-this-file?
                    get-filename
                    make-visible))
+
+(define focus-table<%> (interface ((class->interface frame%))))
+(define focus-table-mixin
+  (mixin (top-level-window<%>) (focus-table<%>)
+    (inherit get-eventspace)
+    
+    (define/override (show on?)
+      (define old (remove this (frame:lookup-focus-table (get-eventspace))))
+      (define new (if on? (cons this old) old))
+      (frame:set-focus-table (get-eventspace) new)
+      (super show on?))
+    
+    (define/augment (on-close)
+      (frame:set-focus-table (get-eventspace) (remove this (frame:lookup-focus-table (get-eventspace))))
+      (inner (void) on-close))
+    
+    (super-new)
+    
+    (frame:set-focus-table (get-eventspace) (frame:lookup-focus-table (get-eventspace)))))
+
 (define basic-mixin
   (mixin ((class->interface frame%)) (basic<%>)
     
@@ -190,12 +211,11 @@
       (λ (% parent)
         (make-object % parent)))
     
-    (inherit can-close? on-close)
+    (inherit on-close can-close?)
-    (define/public close
+    (define/public (close)
-      (λ ()
+      (when (can-close?)
-        (when (can-close?)
+        (on-close)
-          (on-close)
+        (show #f)))
-          (show #f))))
     
     (inherit accept-drop-files)
     
@@ -2710,7 +2730,7 @@
     (min-width (+ (inexact->exact (ceiling indicator-width)) 4))
     (min-height (+ (inexact->exact (ceiling indicator-height)) 4))))
 
-(define basic% (register-group-mixin (basic-mixin frame%)))
+(define basic% (focus-table-mixin (register-group-mixin (basic-mixin frame%))))
 (define size-pref% (size-pref-mixin basic%))
 (define info% (info-mixin basic%))
 (define text-info% (text-info-mixin info%))

collects/framework/private/sig.rkt

@@ -256,6 +256,7 @@
   
   (define-signature frame-class^
     (basic<%>
+     focus-table<%>
      size-pref<%>
      register-group<%>
      status-line<%>
@@ -285,6 +286,7 @@
      delegate%
      pasteboard%
      
+     focus-table-mixin
      basic-mixin
      size-pref-mixin
      register-group-mixin

collects/framework/test.rkt

@@ -1,10 +1,12 @@
 #lang at-exp scheme/gui
 
-(require scribble/srcdoc)
+(require scribble/srcdoc
-(require/doc scheme/base scribble/manual)
+         (prefix-in :: framework/private/focus-table))
+(require/doc scheme/base scribble/manual
+             (for-label framework))
 
 (define (test:top-level-focus-window-has? pred)
-  (let ([tlw (get-top-level-focus-window)])
+  (let ([tlw (test:get-active-top-level-window)])
     (and tlw
          (let loop ([tlw tlw])
            (or (pred tlw)
@@ -165,16 +167,30 @@
 (define current-get-eventspaces
   (make-parameter (λ () (list (current-eventspace)))))
 
-(define (get-active-frame)
+(define test:use-focus-table (make-parameter #f))
+
+(define (test:get-active-top-level-window)
   (ormap (λ (eventspace)
            (parameterize ([current-eventspace eventspace])
-             (get-top-level-focus-window)))
+             (cond
+               [(test:use-focus-table)
+                (define lst (::frame:lookup-focus-table))
+                (define focusd (and (not (null? lst)) (car lst)))
+                (when (eq? (test:use-focus-table) 'debug)
+                  (define f2 (get-top-level-focus-window))
+                  (unless (eq? focusd f2)
+                    (eprintf "found mismatch focus-table: ~s vs get-top-level-focus-window: ~s\n" 
+                             (map (λ (x) (send x get-label)) lst) 
+                             (and f2 (list (send f2 get-label))))))
+                focusd]
+               [else
+                (get-top-level-focus-window)])))
          ((current-get-eventspaces))))
 
 (define (get-focused-window)
-  (let ([f (get-active-frame)])
+  (let ([f (test:get-active-top-level-window)])
     (and f
-         (send f get-focus-window))))
+         (send f get-edit-target-window))))
 
 (define time-stamp current-milliseconds)
 
@@ -200,14 +216,13 @@
 ;; get-parent returns () for no parent.
 ;;
 
-(define in-active-frame?
+(define (in-active-frame? window)
-  (λ (window)
+  (let ([frame  (test:get-active-top-level-window)])
-    (let ([frame  (get-active-frame)])
+    (let loop ([window  window])
-      (let loop ([window  window])
+      (cond [(not window) #f]
-        (cond [(not window) #f]
+            [(null? window) #f]  ;; is this test needed?
-              [(null? window) #f]  ;; is this test needed?
+            [(eq? window frame) #t]
-              [(eq? window frame) #t]
+            [else  (loop (send window get-parent))]))))
-              [else  (loop (send window get-parent))])))))
 
 ;;
 ;; Verify modifier list.
@@ -239,7 +254,7 @@
     (cond
       [(or (string? b-desc)
            (procedure? b-desc))
-       (let* ([active-frame (get-active-frame)]
+       (let* ([active-frame (test:get-active-top-level-window)]
               [_ (unless active-frame
                    (error object-tag
                           "could not find object: ~a, no active frame" 
@@ -516,7 +531,7 @@
              [else 
               (error
                key-tag
-               "focused window is not a text-field% and does not have on-char")])]
+               "focused window is not a text-field% and does not have on-char, ~e" window)])]
           [(send (car l) on-subwindow-char window event) #f]
           [else (loop (cdr l))])))
 
@@ -573,21 +588,20 @@
 
 (define menu-tag 'test:menu-select)
 
-(define menu-select
+(define (menu-select menu-name . item-names)
-  (λ (menu-name . item-names)
+  (cond
-    (cond
+    [(not (string? menu-name))
-      [(not (string? menu-name))
+     (error menu-tag "expects string, given: ~e" menu-name)]
-       (error menu-tag "expects string, given: ~e" menu-name)]
+    [(not (andmap string? item-names))
-      [(not (andmap string? item-names))
+     (error menu-tag "expects strings, given: ~e" item-names)]
-       (error menu-tag "expects strings, given: ~e" item-names)]
+    [else
-      [else
+     (run-one
-       (run-one
+      (λ ()
-        (λ ()
+        (let* ([frame (test:get-active-top-level-window)]
-          (let* ([frame (get-active-frame)]
+               [item (get-menu-item frame (cons menu-name item-names))]
-                 [item (get-menu-item frame (cons menu-name item-names))]
+               [evt (make-object control-event% 'menu)])
-                 [evt (make-object control-event% 'menu)])
+          (send evt set-time-stamp (current-milliseconds))
-            (send evt set-time-stamp (current-milliseconds))
+          (send item command evt))))]))
-            (send item command evt))))])))
 
 (define get-menu-item
   (λ (frame item-names)
@@ -1021,7 +1035,7 @@
   test:top-level-focus-window-has?
   (-> (-> (is-a?/c area<%>) boolean?) boolean?)
   (test)
-  @{Calls @racket[test] for each child of the top-level-focus-frame
+  @{Calls @racket[test] for each child of the @racket[test:get-active-top-level-window]
           and returns @racket[#t] if @racket[test] ever does, otherwise
           returns @racket[#f]. If there
           is no top-level-focus-window, returns @racket[#f].})
@@ -1041,4 +1055,20 @@
   test:run-one
   (-> (-> void?) void?)
   (f)
-  @{Runs the function @racket[f] as if it was a simulated event.}))
+  @{Runs the function @racket[f] as if it was a simulated event.})
+ 
+ (parameter-doc
+  test:use-focus-table
+  (parameter/c (or/c boolean? 'debug))
+  use-focus-table?
+  @{If @racket[#t], then the test framework uses @racket[frame:lookup-focus-table] to determine
+    which is the focused frame. If @racket[#f], then it uses @racket[get-top-level-focus-window].
+    If @racket[test:use-focus-table]'s value is @racket['debug], then it still uses 
+    @racket[frame:lookup-focus-table] but it also prints a message to the @racket[current-error-port]
+    when the two methods would give different results.})
+ 
+ (proc-doc/names
+  test:get-active-top-level-window
+  (-> (or/c (is-a?/c frame%) (is-a?/c dialog%) #f))
+  ()
+  @{Returns the frontmost frame, based on @racket[test:use-focus-table].}))

collects/scribblings/framework/frame.scrbl

@@ -162,6 +162,35 @@
     using the @method[frame:basic<%> make-root-area-container] method).
   }
 }
+
+@definterface[frame:focus-table<%> (frame%)]{}
+
+@defmixin[frame:focus-table-mixin (frame%) (frame:focus-table<%>)]{
+
+  Instances of classes returned from this mixin track how frontmost they are
+  based on calls made to methods at the Racket level, instead of using
+  the calls made by the operating system as it tracks the focus.
+  
+  See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table]
+  and @racket[test:get-active-top-level-window].
+                                                         
+  @defmethod[#:mode override (show [on? boolean?]) void?]{
+    When @racket[on?] is @racket[#t], adds this frame to the 
+    front of the list of frames stored with the frame's eventspace. When 
+    @racket[on?] is @racket[#f], this method removes this frame
+    from the list.
+
+    See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table]
+    and @racket[test:get-active-top-level-window].
+  }
+  @defmethod[#:mode augment (on-close) void?]{
+    Removes this frame from the list of frames stored with the frame's eventspace.
+    
+    See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table]
+    and @racket[test:get-active-top-level-window].
+  }
+}
+                                                     
 @definterface[frame:size-pref<%> (frame:basic<%>)]{
 
 }

collects/scribblings/framework/main-extracts.rkt

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 (require scribble/extract)
 
 (provide-extracted (lib "framework/main.rkt"))