enforce modality; more on-subwindow- callbacks; Cocoa font tweaks

original commit: e9e180847a72ba91ea817fc3b5fc1a457e676747

collects/mred/private/wx/cocoa/button.rkt

@@ -24,7 +24,7 @@
 (define MIN-BUTTON-WIDTH 72)
 
 (define-objc-class MyButton NSButton
-  #:mixins (FocusResponder)
+  #:mixins (FocusResponder KeyMouseResponder)
   [wx]
   (-a _void (clicked: [_id sender])
       (queue-window-event wx (lambda () (send wx clicked)))))

collects/mred/private/wx/cocoa/choice.rkt

@@ -19,7 +19,7 @@
 (import-class NSPopUpButton)
 
 (define-objc-class MyPopUpButton NSPopUpButton 
-  #:mixins (FocusResponder)
+  #:mixins (FocusResponder KeyMouseResponder)
   [wx]
   (-a _void (clicked: [_id sender])
       (queue-window-event wx (lambda () (send wx clicked)))))

collects/mred/private/wx/cocoa/frame.rkt

@@ -27,16 +27,20 @@
 (define empty-mb (new menu-bar%))
 (define root-fake-frame #f)
 
+(define dialog-level-counter 0)
+
 (define-objc-mixin (MyWindowMethods Superclass)
   [wx]
   [-a _scheme (getEventspace)
       (send wx get-eventspace)]
-  [-a _BOOL (canBecomeKeyWindow) #t]
+  [-a _BOOL (canBecomeKeyWindow)
+      (not (other-modal? wx))]
   [-a _BOOL (canBecomeMainWindow) #t]
   [-a _BOOL (windowShouldClose: [_id win])
       (queue-window-event wx (lambda ()
-                               (when (send wx on-close)
+                               (unless (other-modal? wx)
-                                 (send wx direct-show #f))))
+                                 (when (send wx on-close)
+                                   (send wx direct-show #f)))))
       #f]
   [-a _void (windowDidResize: [_id notification])
       (when wx
@@ -149,7 +153,21 @@
        (tell NSGraphicsContext graphicsContextWithWindow: cocoa)))
 
     (define is-a-dialog? is-dialog?)
+    (define dialog-level 0)
     (define/public (frame-is-dialog?) is-a-dialog?)
+    (define/public (frame-relative-dialog-status win) 
+      ;; called in event-pump thread
+      (cond
+       [is-a-dialog? (let ([dl (send win get-dialog-level)])
+                       (cond
+                        [(= dl dialog-level) 'same]
+                        [(dl . > . dialog-level) #f]
+                        [else 'other]))]
+       [else #f]))
+    
+    (define/override (get-dialog-level) 
+      ;; called in event-pump thread
+      dialog-level)
 
     (define/public (clean-up)
       ;; When a window is resized, then any drawing that is in flight
@@ -171,25 +189,32 @@
            (set! front #f)
            (send empty-mb install))
          (if on?
-             (if (and is-a-dialog?
-                      (let ([p (get-parent)])
-                        (and p 
-                             (not (send p get-sheet)))))
-                 (let ([p (get-parent)])
-                   (send p set-sheet this)
-                   (tell (tell NSApplication sharedApplication)
-                         beginSheet: cocoa
-                         modalForWindow: (send p get-cocoa)
-                         modalDelegate: #f
-                         didEndSelector: #:type _SEL #f
-                         contextInfo: #f))
-                 (tellv cocoa makeKeyAndOrderFront: #f))
              (begin
                (when is-a-dialog?
+                 (set! dialog-level-counter (add1 dialog-level-counter))
+                 (set! dialog-level dialog-level-counter))
+               (if (and is-a-dialog?
+                        (let ([p (get-parent)])
+                          (and p 
+                               (not (send p get-sheet)))))
+                   (let ([p (get-parent)])
+                     (send p set-sheet this)
+                     (tell (tell NSApplication sharedApplication)
+                           beginSheet: cocoa
+                           modalForWindow: (send p get-cocoa)
+                           modalDelegate: #f
+                           didEndSelector: #:type _SEL #f
+                           contextInfo: #f))
+                   (tellv cocoa makeKeyAndOrderFront: #f)))
+             (begin
+               (when is-a-dialog?
+                 (set! dialog-level 0)
                  (let ([p (get-parent)])
                    (when (and p
                               (eq? this (send p get-sheet)))
-                     (send p set-sheet #f))))
+                     (send p set-sheet #f)
+                     (tell (tell NSApplication sharedApplication)
+                           endSheet: cocoa))))
                (tellv cocoa orderOut: #f)
                (let ([next
                       (let* ([pool (tell (tell NSAutoreleasePool alloc) init)]
@@ -316,7 +341,7 @@
     (define/public (set-modified on?)
       ;; Use standardWindowButton: ...
       (void))
-
+    
     (define/public (create-status-line) (void))
     (define/public (set-status-text s) (void))
     (def/public-unimplemented status-line-exists?)

collects/mred/private/wx/cocoa/group-panel.rkt

@@ -14,6 +14,10 @@
 
 (import-class NSBox)
 
+(define-objc-class MyBox NSBox
+  #:mixins (FocusResponder KeyMouseResponder)
+  [wx])
+
 (defclass group-panel% (panel-mixin window%)
   (init parent
         x y w h
@@ -24,7 +28,7 @@
   (super-new [parent parent]
              [cocoa
               (let ([cocoa (as-objc-allocation
-                            (tell (tell NSBox alloc) init))])
+                            (tell (tell MyBox alloc) init))])
                 (when label
                   (tellv cocoa setTitle: #:type _NSString label)
                   (tellv cocoa sizeToFit))

collects/mred/private/wx/cocoa/list-box.rkt

@@ -22,6 +22,7 @@
 (import-protocol NSTableViewDataSource)
 
 (define-objc-class MyTableView NSTableView
+  #:mixins (FocusResponder KeyMouseResponder)
   [wx]
   [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row])
       (tell (tell NSCell alloc) initTextCell: #:type _NSString (send wx get-row row))]

collects/mred/private/wx/cocoa/message.rkt

@@ -4,10 +4,11 @@
          ffi/objc
          racket/draw/bitmap
           "../../syntax.rkt"
-         "item.rkt"
+          "window.rkt"
-         "utils.rkt"
+          "item.rkt"
-         "types.rkt"
+          "utils.rkt"
-         "image.rkt")
+          "types.rkt"
+          "image.rkt")
 (unsafe!)
 (objc-unsafe!)
 
@@ -30,6 +31,14 @@
               #:type _NSString
               "NSApplicationPath")))
 
+(define-objc-class MyTextField NSTextField
+  #:mixins (FocusResponder KeyMouseResponder)
+  [wx])
+
+(define-objc-class MyImageView NSImageView
+  #:mixins (FocusResponder KeyMouseResponder)
+  [wx])
+
 (defclass message% item%
   (init parent label
         x y
@@ -59,9 +68,9 @@
                            [cocoa
                             (if (string? label)
                                 (as-objc-allocation
-                                 (tell (tell NSTextField alloc) init))
+                                 (tell (tell MyTextField alloc) init))
                                 (as-objc-allocation
-                                 (tell (tell NSImageView alloc) init)))])
+                                 (tell (tell MyImageView alloc) init)))])
                       (cond
                        [(string? label)
                         (init-font cocoa font)

collects/mred/private/wx/cocoa/radio-box.rkt

@@ -24,7 +24,7 @@
 (define NSListModeMatrix 2)
 
 (define-objc-class MyMatrix NSMatrix
-  #:mixins (FocusResponder)
+  #:mixins (FocusResponder KeyMouseResponder)
   [wx]
   (-a _void (clicked: [_id sender])
       (queue-window-event wx (lambda () (send wx clicked)))))

collects/mred/private/wx/cocoa/slider.rkt

@@ -22,7 +22,7 @@
 (import-class NSSlider)
 
 (define-objc-class MySlider NSSlider
-  #:mixins (FocusResponder)
+  #:mixins (FocusResponder KeyMouseResponder)
   [wx]
   (-a _void (changed: [_id sender])
       (queue-window-event wx (lambda () (send wx changed)))

collects/mred/private/wx/cocoa/tab-panel.rkt

@@ -18,6 +18,7 @@
 (import-protocol NSTabViewDelegate)
 
 (define-objc-class MyTabView NSTabView
+  #:mixins (FocusResponder KeyMouseResponder)
   #:protocols (NSTabViewDelegate)
   [wx]
   (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])

collects/mred/private/wx/cocoa/window.rkt

@@ -8,6 +8,7 @@
          "types.rkt"
          "keycode.rkt"
          "../common/event.rkt"
+         "../common/queue.rkt"
          "../../syntax.rkt"
          "../common/freeze.rkt")
 (unsafe!)
@@ -180,6 +181,10 @@
     (define/public (get-cocoa-window) (send parent get-cocoa-window))
     (define/public (get-wx-window) (send parent get-wx-window))
 
+    (define/public (get-dialog-level) 
+      ;; called in event-pump thread
+      (send parent get-dialog-level))
+
     (define/public (make-graphics-context)
       (and parent
            (send parent make-graphics-context)))
@@ -294,11 +299,13 @@
 
     (define/public (dispatch-on-char e just-pre?) 
       (cond
+       [(other-modal? this) #t]
        [(call-pre-on-char this e) #t]
        [just-pre? #f]
        [else (when enabled? (on-char e)) #t]))
     (define/public (dispatch-on-event e just-pre?) 
       (cond
+       [(other-modal? this) #t]
        [(call-pre-on-event this e) #t]
        [just-pre? #f]
        [else (when enabled? (on-event e)) #t]))

collects/mred/private/wx/common/queue.rkt

@@ -2,6 +2,7 @@
 (require ffi/unsafe
          racket/draw/utils
          ffi/unsafe/atomic
+         racket/class
          "rbtree.rkt"
          "../../lock.rkt"
          "handlers.rkt")
@@ -35,6 +36,7 @@
 
          register-frame-shown
          get-top-level-windows
+         other-modal?
 
          queue-quit-event)
 
@@ -329,9 +331,20 @@
                                           'frame-remove)))
 
 (define (get-top-level-windows)
+  ;; called in event-pump thread
   (hash-map (eventspace-frames-hash (current-eventspace))
             (lambda (k v) k)))
 
+(define (other-modal? win)
+  ;; called in event-pump thread
+  (let loop ([frames (get-top-level-windows)]) 
+    (and (pair? frames)
+         (let ([status (send (car frames) frame-relative-dialog-status win)])
+           (case status
+             [(#f) (loop (cdr frames))]
+             [(same) #f]
+             [(other) #t])))))
+
 (define (queue-quit-event)
   ;; called in event-pump thread
   (queue-event main-eventspace (application-quit-handler) 'med))

collects/mred/private/wx/gtk/choice.rkt

@@ -62,6 +62,8 @@
              [callback cb]
              [no-show? (memq 'deleted style)])
 
+  (connect-key-and-mouse button-gtk)
+
   (gtk_combo_box_set_active gtk 0)
 
   (set-auto-size)

collects/mred/private/wx/gtk/dialog.rkt

@@ -18,6 +18,8 @@
 (define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void))
 (define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void))
 
+(define dialog-level-counter 0)
+
 (defclass dialog% frame%
   (inherit get-gtk
            get-parent)
@@ -32,7 +34,22 @@
     (when p
       (gtk_window_set_transient_for (get-gtk) (send p get-gtk))))
 
+  (define dialog-level 0)
+  (define/override (get-dialog-level) dialog-level)
+  
+  (define/override (frame-relative-dialog-status win) 
+    (let ([dl (send win get-dialog-level)])
+      (cond
+       [(= dl dialog-level) 'same]
+       [(dl . > . dialog-level) #f]
+       [else 'other])))
+  
   (define/override (direct-show on?)
+    (when on?
+      (set! dialog-level-counter (add1 dialog-level-counter))
+      (set! dialog-level dialog-level-counter))
+    (unless on?
+      (set! dialog-level 0))
     (unless on?
       (when close-sema
         (semaphore-post close-sema)

collects/mred/private/wx/gtk/frame.rkt

@@ -52,14 +52,14 @@
 (define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void))
 
 
-(define (handle-delete gtk)
+(define-signal-handler connect-delete "delete-event"
-  (let ([wx (gtk->wx gtk)])
+  (_fun _GtkWidget -> _gboolean)
-    (queue-window-event wx (lambda () 
+  (lambda (gtk)
-                             (when (send wx on-close)
+    (let ([wx (gtk->wx gtk)])
-                               (send wx direct-show #f))))))
+      (queue-window-event wx (lambda () 
-(define handle_delete
+                               (unless (other-modal? wx)
-  (function-ptr handle-delete
+                                 (when (send wx on-close)
-                (_fun #:atomic? #t _GtkWidget -> _gboolean)))
+                                   (send wx direct-show #f))))))))
 
 (define-signal-handler connect-configure "configure-event"
   (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean)
@@ -121,7 +121,7 @@
 
     (set-size x y w h)
 
-    (g_signal_connect gtk "delete_event" handle_delete)
+    (connect-delete gtk)
     (connect-configure gtk)
 
     (when label
@@ -159,6 +159,9 @@
     (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1)))
     (define/public (get-dc-lock) dc-lock)
 
+    (define/override (get-dialog-level) 0)
+    (define/public (frame-relative-dialog-status win) #f)
+
     (define/override (center dir wrt)
       (let ([w-box (box 0)]
             [h-box (box 0)]

collects/mred/private/wx/gtk/menu-bar.rkt

@@ -3,6 +3,7 @@
          scheme/foreign
           "../../syntax.rkt"
           "../common/freeze.rkt"
+          "../common/queue.rkt"
           "widget.rkt"
           "utils.rkt"
           "types.rkt")
@@ -49,7 +50,17 @@
     (define/public (get-top-window) (send parent get-top-window))
     (super-new)))
 
+(define-signal-handler connect-menu-key-press "key-press-event"
+  (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean)
+  (lambda (gtk event)
+    (let ([wx (gtk->wx gtk)])
+      (other-modal? wx))))
 
+(define-signal-handler connect-menu-button-press "button-press-event"
+  (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
+  (lambda (gtk event)
+    (let ([wx (gtk->wx gtk)])
+      (other-modal? wx))))
 
 (defclass menu-bar% widget%
   (define menus null)
@@ -59,12 +70,18 @@
 
   (define/public (get-gtk) gtk)
 
+  (connect-menu-key-press gtk)
+  (connect-menu-button-press gtk)
+
   (define top-wx #f)
   (define/public (set-top-window top)
     (set! top-wx top))
   (define/public (get-top-window)
     top-wx)
 
+  (define/public (get-dialog-level) 
+    (send top-wx get-dialog-level))
+
   (define/public (set-label-top pos str)
     (let ([l (list-ref menus pos)])
       (let ([item-gtk (car l)])

collects/mred/private/wx/gtk/tab-panel.rkt

@@ -86,6 +86,8 @@
                [extra-gtks (list client-gtk)]
                [no-show? (memq 'deleted style)])
 
+    (connect-key-and-mouse gtk)
+
     (set-auto-size)
 
     (define callback void)

collects/mred/private/wx/gtk/window.rkt

@@ -5,6 +5,7 @@
          "../../syntax.rkt"
          "../common/event.rkt"
          "../common/freeze.rkt"
+         "../common/queue.rkt"
          "keycode.rkt"
          "queue.rkt"
          "utils.rkt"
@@ -107,7 +108,8 @@
   (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
   (lambda (gtk event)
     (unless (gtk_widget_is_focus gtk)
-      (gtk_widget_grab_focus gtk))
+      (unless (other-modal? (gtk->wx gtk))
+        (gtk_widget_grab_focus gtk)))
     (do-button-event gtk event #f #f)))
 
 (define-signal-handler connect-button-release "button-release-event"
@@ -335,6 +337,8 @@
 
     (define/public (get-top-win) (send parent get-top-win))
 
+    (define/public (get-dialog-level) (send parent get-dialog-level))
+
     (define/public (get-size xb yb)
       (set-box! xb save-w)
       (set-box! yb save-h))
@@ -365,11 +369,13 @@
     (define/public (handles-events?) #f)
     (define/public (dispatch-on-char e just-pre?) 
       (cond
+       [(other-modal? this) #t]
        [(call-pre-on-char this e) #t]
        [just-pre? #f]
        [else (when enabled? (on-char e)) #t]))
     (define/public (dispatch-on-event e just-pre?) 
       (cond
+       [(other-modal? this) #t]
        [(call-pre-on-event this e) #t]
        [just-pre? #f]
        [else (when enabled? (on-event e)) #t]))