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

collects/ffi/unsafe.rkt

@@ -558,7 +558,8 @@
     ;; parse keywords
     (let loop ()
       (let ([k (and (pair? xs) (pair? (cdr xs)) (car xs))])
-        (when (keyword? (syntax-e k))
+        (when (and (syntax? k)
+                   (keyword? (syntax-e k)))
           (kwd-set! k (cadr xs))
           (set! xs (cddr xs))
           (loop))))

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

collects/racket/draw/dc.rkt

@@ -48,6 +48,8 @@
        (real? (vector-ref v 4))
        (real? (vector-ref v 5))))
 
+(define substitute-fonts? (memq (system-type) '(macosx)))
+
 ;; dc-backend : interface
 ;;
 ;; This is the interface that the backend specific code must implement
@@ -933,7 +935,8 @@
                     (when attrs (pango_layout_set_attributes layout attrs))
                     (pango_layout_set_text layout s)
                     (let ([next-s
-                           (if (zero? (pango_layout_get_unknown_glyphs_count layout))
+                           (if (or (not substitute-fonts?)
+                                   (zero? (pango_layout_get_unknown_glyphs_count layout)))
                                #f
                                ;; look for the first character in the string without a glyph
                                (let ([ok-count
@@ -953,7 +956,7 @@
                                  (pango_layout_set_text layout (substring s 0 (max 1 ok-count)))
                                  (when (zero? ok-count)
                                    ;; find a face that works for the long character:
-                                   (install-alternate-face layout font desc attrs))
+                                   (install-alternate-face (string-ref s 0) layout font desc attrs context))
                                  (substring s (max 1 ok-count))))])
                       (when draw?
                         (cairo_move_to cr (+ x w) y)
@@ -986,9 +989,10 @@
                                                 (pango_layout_set_font_description layout desc)
                                                 (when attrs (pango_layout_set_attributes layout attrs))
                                                 (pango_layout_set_text layout (string ch))
-                                                (unless (zero? (pango_layout_get_unknown_glyphs_count layout))
+                                                (unless (or (not substitute-fonts?)
+                                                            (zero? (pango_layout_get_unknown_glyphs_count layout)))
                                                   ;; No good glyph; look for an alternate face
-                                                  (install-alternate-face layout font desc attrs))
+                                                  (install-alternate-face ch layout font desc attrs context))
                                                 (hash-set! layouts key layout)
                                                 layout)))])
                      (pango_cairo_update_layout cr layout)
@@ -1006,9 +1010,11 @@
                  (when rotate? (cairo_restore cr))))))))
 
 
-    (define/private (install-alternate-face layout font desc attrs)
+    (define/private (install-alternate-face ch layout font desc attrs context)
       (or
-       (for/or ([face (in-list (get-face-list))])
+       (for/or ([face (in-list 
+                       ;; Hack: prefer Lucida Grande
+                       (cons "Lucida Grande" (get-face-list)))])
          (let ([desc (get-pango (make-object font%
                                              (send font get-point-size)
                                              face
@@ -1198,7 +1204,8 @@
       (with-cr
        #f
        cr
-       (let ([desc (get-pango font)])
+       (let ([desc (get-pango font)]
+             [attrs (send font get-pango-attrs)])
          (unless context
            (set! context (pango_cairo_create_context cr)))
          (let ([layout (pango_layout_new context)])
@@ -1206,8 +1213,11 @@
            (pango_layout_set_text layout (string c))
            (pango_cairo_update_layout cr layout)
            (begin0
-            (zero? (pango_layout_get_unknown_glyphs_count layout))
+            (or (zero? (pango_layout_get_unknown_glyphs_count layout))
+                (and substitute-fonts?
+                     (install-alternate-face c layout font desc attrs context)
+                     (zero? (pango_layout_get_unknown_glyphs_count layout))))
             (g_object_unref layout))))))
     
     )
-  dc%)
+  dc%)

collects/racket/draw/font.rkt

@@ -194,5 +194,9 @@
 
 (define (get-face-list [mode 'all])
   (map pango_font_family_get_name
-       (pango_font_map_list_families
+       (let ([fams (pango_font_map_list_families
-        (pango_cairo_font_map_get_default))))
+                    (pango_cairo_font_map_get_default))])
+         (if (eq? mode 'mono)
+             (filter pango_font_family_is_monospace fams)
+             fams))))
+