better dialog support (sheets for Cocoa, centering in gtk)

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

@@ -2,11 +2,14 @@
 
 (provide (except-out (all-defined-out) <<))
 
+(define (<< a b) (arithmetic-shift a b))
+
 (define NSTitledWindowMask 1)
 (define NSBorderlessWindowMask 0)
 (define NSClosableWindowMask 2)
 (define NSMiniaturizableWindowMask 4)
 (define NSResizableWindowMask 8)
+(define NSUtilityWindowMask (1 . << . 4))
 (define NSTexturedBackgroundWindowMask 256)
 
 (define NSBackingStoreBuffered 2)
@@ -15,8 +18,6 @@
 
 (define NSAnyEventMask #xffffffff)
 
-(define (<< a b) (arithmetic-shift a b))
-
 (define NSAlphaShiftKeyMask (1 . << . 16))
 (define NSShiftKeyMask (1 . << . 17))
 (define NSControlKeyMask (1 . << . 18))

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

@@ -21,6 +21,9 @@
            (set! close-sema #f)))))
     (super direct-show on?))
 
+  ;; #t result avoids children sheets
+  (define/override (get-sheet) #t)
+
   (define/override (show on?)
     (if on?
         (let ([s (as-entry

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

@@ -19,7 +19,7 @@
 
 ;; ----------------------------------------
 
-(import-class NSWindow NSGraphicsContext NSMenu 
+(import-class NSWindow NSGraphicsContext NSMenu NSPanel
               NSApplication NSAutoreleasePool)
 
 (define front #f)
@@ -27,8 +27,7 @@
 (define empty-mb (new menu-bar%))
 (define root-fake-frame #f)
 
-(define-objc-class MyWindow NSWindow
+(define-objc-mixin (MyWindowMethods Superclass)
-  #:mixins (FocusResponder KeyMouseResponder)
   [wx]
   [-a _scheme (getEventspace)
       (send wx get-eventspace)]
@@ -61,6 +60,14 @@
         (queue-window-event wx (lambda ()
                                  (send wx on-activate #f))))])
 
+(define-objc-class MyWindow NSWindow
+  #:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
+  [wx])
+
+(define-objc-class MyPanel NSPanel
+  #:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
+  [wx])
+
 (set-front-hook! (lambda () (values front
                                     (and front (send front get-eventspace)))))
 
@@ -86,13 +93,20 @@
           style)
     (init [is-dialog? #f])
 
-    (inherit get-cocoa
+    (inherit get-cocoa get-parent
              pre-on-char pre-on-event)
 
-    (super-new [parent #f]
+    (super-new [parent parent]
                [cocoa
+                (let ([is-sheet? (and #f
+                                      is-dialog? 
+                                      parent
+                                      (not (send parent frame-is-dialog?)))])
                   (as-objc-allocation
-                 (tell (tell MyWindow alloc)
+                   (tell (tell (if is-sheet?
+                                   MyPanel
+                                   MyWindow)
+                               alloc)
                          initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)])
                                                                (make-NSRect (make-NSPoint x y)
                                                                             (make-NSSize (max 30 w) 
@@ -101,6 +115,7 @@
                                                     NSBorderlessWindowMask
                                                     (bitwise-ior 
                                                      NSTitledWindowMask
+                                                     (if is-sheet? NSUtilityWindowMask 0)
                                                      (if is-dialog?
                                                          0
                                                          (bitwise-ior 
@@ -110,7 +125,7 @@
                                                               0
                                                               NSResizableWindowMask)))))
                          backing: #:type _int NSBackingStoreBuffered
-                       defer: #:type _BOOL NO))]
+                         defer: #:type _BOOL NO)))]
                [no-show? #t])
     (define cocoa (get-cocoa))
     (tellv cocoa setDelegate: cocoa)
@@ -126,6 +141,9 @@
       (as-objc-allocation
        (tell NSGraphicsContext graphicsContextWithWindow: cocoa)))
 
+    (define is-a-dialog? is-dialog?)
+    (define/public (frame-is-dialog?) is-a-dialog?)
+
     (define/public (clean-up)
       ;; When a window is resized, then any drawing that is in flight
       ;; might draw outside the canvas boundaries. Just refresh everything.
@@ -134,6 +152,10 @@
     (when label
       (tellv cocoa setTitle: #:type _NSString label))
     
+    (define child-sheet #f)
+    (define/public (get-sheet) child-sheet)
+    (define/public (set-sheet s) (set! child-sheet s))
+
     (define/public (direct-show on?)
       (as-entry
        (lambda ()
@@ -142,8 +164,25 @@
            (set! front #f)
            (send empty-mb install))
          (if on?
-             (tellv cocoa makeKeyAndOrderFront: #f)
+             (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?
+                 (let ([p (get-parent)])
+                   (when (and p
+                              (eq? this (send p get-sheet)))
+                     (send p set-sheet #f))))
                (tellv cocoa orderOut: #f)
                (let ([next
                       (let* ([pool (tell (tell NSAutoreleasePool alloc) init)]
@@ -185,7 +224,18 @@
         (move x y))
       (let ([f (tell #:type _NSRect cocoa frame)])
         (tellv cocoa setFrame: 
-               #:type _NSRect (make-NSRect (make-NSPoint (NSPoint-x (NSRect-origin f))
+               #:type _NSRect (make-NSRect 
+                               (make-NSPoint (if (and is-a-dialog?
+                                                      (let ([p (get-parent)])
+                                                        (and p
+                                                             (eq? this (send p get-sheet)))))
+                                                 ;; need to re-center sheet:
+                                                 (let* ([p (get-parent)]
+                                                        [px (send p get-x)]
+                                                        [pw (send p get-width)])
+                                                   (+ px (/ (- pw w) 2)))
+                                                 ;; keep current x position:
+                                                 (NSPoint-x (NSRect-origin f)))
                                              (- (NSPoint-y (NSRect-origin f))
                                                 (- h
                                                    (NSSize-height (NSRect-size f)))))

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

@@ -40,7 +40,10 @@
     (super direct-show on?))
 
   (define/override (center dir wrt)
-    (if (eq? dir 'both)
+    ;; We're supposed to use gtk_window_set_position() for dialogs,
+    ;;  but we must be doing something else wrong so that it doesn't
+    ;;  work.
+    (if #f ; (eq? dir 'both)
         (gtk_window_set_position (get-gtk) 
                                  (if (get-parent)
                                      GTK_WIN_POS_CENTER_ON_PARENT

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

@@ -96,7 +96,8 @@
    
     (inherit get-gtk set-size on-size
              pre-on-char pre-on-event
-             get-client-delta get-size)
+             get-client-delta get-size
+             get-parent)
 
     (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL))
     (when (memq 'no-caption style)
@@ -161,21 +162,29 @@
     (define/override (center dir wrt)
       (let ([w-box (box 0)]
             [h-box (box 0)]
+            [sx-box (box 0)]
+            [sy-box (box 0)]
             [sw-box (box 0)]
             [sh-box (box 0)])
         (get-size w-box h-box)
-        (display-size sw-box sh-box #t)
+        (let ([p (get-parent)])
+          (if p
+              (begin
+                (send p get-size sw-box sh-box)
+                (set-box! sx-box (send p get-x))
+                (set-box! sy-box (send p get-y)))
+              (display-size sw-box sh-box #t)))
         (let* ([sw (unbox sw-box)]
                [sh (unbox sh-box)]
                [fw (unbox w-box)]
                [fh (unbox h-box)])
           (set-top-position (if (or (eq? dir 'both)
                                     (eq? dir 'horizontal))
-                                (quotient (- sw fw) 2)
+                                (+ (unbox sx-box) (quotient (- sw fw) 2))
                                 -11111)
                             (if (or (eq? dir 'both)
                                     (eq? dir 'vertical))
-                                (quotient (- sh fh) 2)
+                                (+ (unbox sy-box) (quotient (- sh fh) 2))
                                 -11111)))))
 
     (define/public (set-top-position x y)