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

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

@ -21,6 +21,9 @@
(set! close-sema #f))))) (set! close-sema #f)))))
(super direct-show on?)) (super direct-show on?))
;; #t result avoids children sheets
(define/override (get-sheet) #t)
(define/override (show on?) (define/override (show on?)
(if on? (if on?
(let ([s (as-entry (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) NSApplication NSAutoreleasePool)
(define front #f) (define front #f)
@ -27,8 +27,7 @@
(define empty-mb (new menu-bar%)) (define empty-mb (new menu-bar%))
(define root-fake-frame #f) (define root-fake-frame #f)
(define-objc-class MyWindow NSWindow (define-objc-mixin (MyWindowMethods Superclass)
#:mixins (FocusResponder KeyMouseResponder)
[wx] [wx]
[-a _scheme (getEventspace) [-a _scheme (getEventspace)
(send wx get-eventspace)] (send wx get-eventspace)]
@ -61,6 +60,14 @@
(queue-window-event wx (lambda () (queue-window-event wx (lambda ()
(send wx on-activate #f))))]) (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 (set-front-hook! (lambda () (values front
(and front (send front get-eventspace))))) (and front (send front get-eventspace)))))
@ -86,31 +93,39 @@
style) style)
(init [is-dialog? #f]) (init [is-dialog? #f])
(inherit get-cocoa (inherit get-cocoa get-parent
pre-on-char pre-on-event) pre-on-char pre-on-event)
(super-new [parent #f] (super-new [parent parent]
[cocoa [cocoa
(as-objc-allocation (let ([is-sheet? (and #f
(tell (tell MyWindow alloc) is-dialog?
initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)]) parent
(make-NSRect (make-NSPoint x y) (not (send parent frame-is-dialog?)))])
(make-NSSize (max 30 w) (as-objc-allocation
(max 0 h)))) (tell (tell (if is-sheet?
styleMask: #:type _int (if (memq 'no-caption style) MyPanel
NSBorderlessWindowMask MyWindow)
(bitwise-ior alloc)
NSTitledWindowMask initWithContentRect: #:type _NSRect (let-values ([(x y) (init-pos x y)])
(if is-dialog? (make-NSRect (make-NSPoint x y)
0 (make-NSSize (max 30 w)
(bitwise-ior (max 0 h))))
NSClosableWindowMask styleMask: #:type _int (if (memq 'no-caption style)
NSMiniaturizableWindowMask NSBorderlessWindowMask
(if (memq 'no-resize-border style) (bitwise-ior
0 NSTitledWindowMask
NSResizableWindowMask))))) (if is-sheet? NSUtilityWindowMask 0)
backing: #:type _int NSBackingStoreBuffered (if is-dialog?
defer: #:type _BOOL NO))] 0
(bitwise-ior
NSClosableWindowMask
NSMiniaturizableWindowMask
(if (memq 'no-resize-border style)
0
NSResizableWindowMask)))))
backing: #:type _int NSBackingStoreBuffered
defer: #:type _BOOL NO)))]
[no-show? #t]) [no-show? #t])
(define cocoa (get-cocoa)) (define cocoa (get-cocoa))
(tellv cocoa setDelegate: cocoa) (tellv cocoa setDelegate: cocoa)
@ -126,6 +141,9 @@
(as-objc-allocation (as-objc-allocation
(tell NSGraphicsContext graphicsContextWithWindow: cocoa))) (tell NSGraphicsContext graphicsContextWithWindow: cocoa)))
(define is-a-dialog? is-dialog?)
(define/public (frame-is-dialog?) is-a-dialog?)
(define/public (clean-up) (define/public (clean-up)
;; When a window is resized, then any drawing that is in flight ;; When a window is resized, then any drawing that is in flight
;; might draw outside the canvas boundaries. Just refresh everything. ;; might draw outside the canvas boundaries. Just refresh everything.
@ -134,6 +152,10 @@
(when label (when label
(tellv cocoa setTitle: #:type _NSString 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?) (define/public (direct-show on?)
(as-entry (as-entry
(lambda () (lambda ()
@ -142,8 +164,25 @@
(set! front #f) (set! front #f)
(send empty-mb install)) (send empty-mb install))
(if on? (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 (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) (tellv cocoa orderOut: #f)
(let ([next (let ([next
(let* ([pool (tell (tell NSAutoreleasePool alloc) init)] (let* ([pool (tell (tell NSAutoreleasePool alloc) init)]
@ -185,11 +224,22 @@
(move x y)) (move x y))
(let ([f (tell #:type _NSRect cocoa frame)]) (let ([f (tell #:type _NSRect cocoa frame)])
(tellv cocoa setFrame: (tellv cocoa setFrame:
#:type _NSRect (make-NSRect (make-NSPoint (NSPoint-x (NSRect-origin f)) #:type _NSRect (make-NSRect
(- (NSPoint-y (NSRect-origin f)) (make-NSPoint (if (and is-a-dialog?
(- h (let ([p (get-parent)])
(NSSize-height (NSRect-size f))))) (and p
(make-NSSize w h)) (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))) display: #:type _BOOL #t)))
(define/override (move x y) (define/override (move x y)
(tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen 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?)) (super direct-show on?))
(define/override (center dir wrt) (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) (gtk_window_set_position (get-gtk)
(if (get-parent) (if (get-parent)
GTK_WIN_POS_CENTER_ON_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 (inherit get-gtk set-size on-size
pre-on-char pre-on-event 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)) (define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL))
(when (memq 'no-caption style) (when (memq 'no-caption style)
@ -161,21 +162,29 @@
(define/override (center dir wrt) (define/override (center dir wrt)
(let ([w-box (box 0)] (let ([w-box (box 0)]
[h-box (box 0)] [h-box (box 0)]
[sx-box (box 0)]
[sy-box (box 0)]
[sw-box (box 0)] [sw-box (box 0)]
[sh-box (box 0)]) [sh-box (box 0)])
(get-size w-box h-box) (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)] (let* ([sw (unbox sw-box)]
[sh (unbox sh-box)] [sh (unbox sh-box)]
[fw (unbox w-box)] [fw (unbox w-box)]
[fh (unbox h-box)]) [fh (unbox h-box)])
(set-top-position (if (or (eq? dir 'both) (set-top-position (if (or (eq? dir 'both)
(eq? dir 'horizontal)) (eq? dir 'horizontal))
(quotient (- sw fw) 2) (+ (unbox sx-box) (quotient (- sw fw) 2))
-11111) -11111)
(if (or (eq? dir 'both) (if (or (eq? dir 'both)
(eq? dir 'vertical)) (eq? dir 'vertical))
(quotient (- sh fh) 2) (+ (unbox sy-box) (quotient (- sh fh) 2))
-11111))))) -11111)))))
(define/public (set-top-position x y) (define/public (set-top-position x y)