suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-02 14:05:51 -06:00
parent 4457c51022
commit cc5cc94510
5 changed files with 104 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/mred/private/wx/cocoa/const.rkt
View File

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

3
collects/mred/private/wx/cocoa/dialog.rkt
View File

@ -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

112
collects/mred/private/wx/cocoa/frame.rkt
View File

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

5
collects/mred/private/wx/gtk/dialog.rkt
View File

@ -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

17
collects/mred/private/wx/gtk/frame.rkt
View File

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