From cc5cc94510bb7d473ccfe74467be1df296ffbea8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 14:05:51 -0600 Subject: [PATCH] better dialog support (sheets for Cocoa, centering in gtk) --- collects/mred/private/wx/cocoa/const.rkt | 5 +- collects/mred/private/wx/cocoa/dialog.rkt | 3 + collects/mred/private/wx/cocoa/frame.rkt | 112 ++++++++++++++++------ collects/mred/private/wx/gtk/dialog.rkt | 5 +- collects/mred/private/wx/gtk/frame.rkt | 17 +++- 5 files changed, 104 insertions(+), 38 deletions(-) diff --git a/collects/mred/private/wx/cocoa/const.rkt b/collects/mred/private/wx/cocoa/const.rkt index 8f6079369c..82c37e0bab 100644 --- a/collects/mred/private/wx/cocoa/const.rkt +++ b/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)) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index 423ff1da6b..9ebc246fb0 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/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 diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 190766c2cf..31f08de86d 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/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 - #:mixins (FocusResponder KeyMouseResponder) +(define-objc-mixin (MyWindowMethods Superclass) [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,31 +93,39 @@ 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 - (as-objc-allocation - (tell (tell MyWindow alloc) - initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) - (make-NSRect (make-NSPoint x y) - (make-NSSize (max 30 w) - (max 0 h)))) - styleMask: #:type _int (if (memq 'no-caption style) - NSBorderlessWindowMask - (bitwise-ior - NSTitledWindowMask - (if is-dialog? - 0 - (bitwise-ior - NSClosableWindowMask - NSMiniaturizableWindowMask - (if (memq 'no-resize-border style) - 0 - NSResizableWindowMask))))) - backing: #:type _int NSBackingStoreBuffered - defer: #:type _BOOL NO))] + (let ([is-sheet? (and #f + is-dialog? + parent + (not (send parent frame-is-dialog?)))]) + (as-objc-allocation + (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) + (max 0 h)))) + styleMask: #:type _int (if (memq 'no-caption style) + NSBorderlessWindowMask + (bitwise-ior + NSTitledWindowMask + (if is-sheet? NSUtilityWindowMask 0) + (if is-dialog? + 0 + (bitwise-ior + NSClosableWindowMask + NSMiniaturizableWindowMask + (if (memq 'no-resize-border style) + 0 + NSResizableWindowMask))))) + backing: #:type _int NSBackingStoreBuffered + 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. @@ -133,6 +151,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 @@ -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,11 +224,22 @@ (move x y)) (let ([f (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: - #:type _NSRect (make-NSRect (make-NSPoint (NSPoint-x (NSRect-origin f)) - (- (NSPoint-y (NSRect-origin f)) - (- h - (NSSize-height (NSRect-size f))))) - (make-NSSize w h)) + #: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))))) + (make-NSSize w h)) display: #:type _BOOL #t))) (define/override (move x y) (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y)))) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 25be184c20..eee9934bf0 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/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 diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 5cf5b9b04a..06e8ee902a 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/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)