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

make platform-to-wx links weak

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-13 16:40:26 -06:00
parent fdf38124a5
commit 0a9bdc11ad
27 changed files with 396 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/mred/private/wx/cocoa/button.rkt
View File

@ -25,9 +25,9 @@
(define-objc-class MyButton NSButton
#:mixins (FocusResponder KeyMouseResponder)
[wx]
[wxb]
(-a _void (clicked: [_id sender])
(queue-window-event wx (lambda () (send wx clicked)))))
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(defclass core-button% item%
(init parent cb label x y w h style font
@ -99,10 +99,12 @@
(tellv button-cocoa setFrame: #:type _NSRect
(make-NSRect (make-NSPoint 0 0)
(make-NSSize new-width new-height)))
(set-ivar! button-cocoa wx this)
(set-ivar! button-cocoa wxb (->wxb this))
cocoa))
button-cocoa))
(define we (make-will-executor))
(super-new [parent parent]
[cocoa cocoa]
[no-show? (memq 'deleted style)]

91
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -28,37 +28,48 @@
(import-protocol NSComboBoxDelegate)
;; Called when a canvas has no backing store ready
(define (clear-background wx)
(let ([bg (send wx get-canvas-background-for-clearing)])
(when bg
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[adj (lambda (v) (/ v 255.0))])
(CGContextSetRGBFillColor cg
(adj (color-red bg))
(adj (color-blue bg))
(adj (color-green bg))
1.0)
(CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
(make-NSSize 32000 32000))))
(tellv ctx restoreGraphicsState)))))
(define (clear-background wxb)
(let ([wx (->wx wxb)])
(when wx
(let ([bg (send wx get-canvas-background-for-clearing)])
(when bg
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[adj (lambda (v) (/ v 255.0))])
(CGContextSetRGBFillColor cg
(adj (color-red bg))
(adj (color-blue bg))
(adj (color-green bg))
1.0)
(CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
(make-NSSize 32000 32000))))
(tellv ctx restoreGraphicsState)))))))
(define-objc-class MyView NSView
#:mixins (FocusResponder KeyMouseResponder)
[wx]
[wxb]
(-a _void (drawRect: [_NSRect r])
(unless (send wx paint-or-queue-paint)
(clear-background wx)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event)))
(when wxb
(let ([wx (->wx wxb)])
(when wx
(unless (send wx paint-or-queue-paint)
(clear-background wxb)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event))))))
(-a _void (viewWillMoveToWindow: [_id w])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc)))))
(when wxb
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc)))))))
(-a _void (onHScroll: [_id scroller])
(when wx (send wx do-scroll 'horizontal scroller)))
(when wxb
(let ([wx (->wx wxb)])
(when wx (send wx do-scroll 'horizontal scroller)))))
(-a _void (onVScroll: [_id scroller])
(when wx (send wx do-scroll 'vertical scroller))))
(when wxb
(let ([wx (->wx wxb)])
(when wx (send wx do-scroll 'vertical scroller))))))
(define-objc-class FrameView NSView
[]
@ -118,22 +129,30 @@
(define-objc-class MyComboBox NSComboBox
#:mixins (FocusResponder KeyMouseResponder)
#:protocols (NSComboBoxDelegate)
[wx]
[wxb]
(-a _void (drawRect: [_NSRect r])
(super-tell #:type _void drawRect: #:type _NSRect r)
(unless (send wx paint-or-queue-paint)
(unless (send wx during-menu-click?)
(clear-background wx)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event))))
(let ([wx (->wx wxb)])
(when wx
(unless (send wx paint-or-queue-paint)
(unless (send wx during-menu-click?)
(clear-background wxb)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event))))))
(-a _void (comboBoxWillPopUp: [_id notification])
(send wx starting-combo))
(let ([wx (->wx wxb)])
(when wx
(send wx starting-combo))))
(-a _void (comboBoxWillDismiss: [_id notification])
(send wx ending-combo))
(let ([wx (->wx wxb)])
(when wx
(send wx ending-combo))))
(-a _void (viewWillMoveToWindow: [_id w])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc))))))
(when wxb
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc))))))))
(define-struct scroller (cocoa [range #:mutable] [page #:mutable]))
(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
@ -247,7 +266,7 @@
(tell (tell (if is-combo? MyComboBox MyView) alloc)
initWithFrame: #:type _NSRect r))))
(tell #:type _void cocoa addSubview: content-cocoa)
(set-ivar! content-cocoa wx this)
(set-ivar! content-cocoa wxb (->wxb this))
(when is-combo?
(tellv content-cocoa setEditable: #:type _BOOL #f)

4
collects/mred/private/wx/cocoa/choice.rkt
View File

@ -20,9 +20,9 @@
(define-objc-class MyPopUpButton NSPopUpButton
#:mixins (FocusResponder KeyMouseResponder)
[wx]
[wxb]
(-a _void (clicked: [_id sender])
(queue-window-event wx (lambda () (send wx clicked)))))
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(defclass choice% item%
(init parent cb label

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

@ -30,49 +30,56 @@
(define dialog-level-counter 0)
(define-objc-mixin (MyWindowMethods Superclass)
[wx]
[wxb]
[-a _scheme (getEventspace)
(send wx get-eventspace)]
(let ([wx (->wx wxb)])
(and wx (send wx get-eventspace)))]
[-a _BOOL (canBecomeKeyWindow)
(not (other-modal? wx))]
(let ([wx (->wx wxb)])
(and wx
(not (other-modal? wx))))]
[-a _BOOL (canBecomeMainWindow) #t]
[-a _BOOL (windowShouldClose: [_id win])
(queue-window-event wx (lambda ()
(unless (other-modal? wx)
(when (send wx on-close)
(send wx direct-show #f)))))
(queue-window*-event wxb (lambda (wx)
(unless (other-modal? wx)
(when (send wx on-close)
(send wx direct-show #f)))))
#f]
[-a _void (windowDidResize: [_id notification])
(when wx
(queue-window-event wx (lambda ()
(send wx on-size 0 0)
(send wx clean-up))))]
(when wxb
(queue-window*-event wxb (lambda (wx)
(send wx on-size 0 0)
(send wx clean-up))))]
[-a _void (windowDidMove: [_id notification])
(when wx
(queue-window-event wx (lambda ()
(send wx on-size 0 0))))]
(when wxb
(queue-window*-event wxb (lambda (wx)
(send wx on-size 0 0))))]
[-a _void (windowDidBecomeMain: [_id notification])
(when wx
(set! front wx)
(send wx install-mb)
(send wx notify-responder #t)
(queue-window-event wx (lambda ()
(send wx on-activate #t))))]
(when wxb
(let ([wx (->wx wxb)])
(when wx
(set! front wx)
(send wx install-mb)
(send wx notify-responder #t)
(queue-window-event wx (lambda ()
(send wx on-activate #t))))))]
[-a _void (windowDidResignMain: [_id notification])
(when wx
(when (eq? front wx) (set! front #f))
(send empty-mb install)
(send wx notify-responder #f)
(queue-window-event wx (lambda ()
(send wx on-activate #f))))])
(when wxb
(let ([wx (->wx wxb)])
(when wx
(when (eq? front wx) (set! front #f))
(send empty-mb install)
(send wx notify-responder #f)
(queue-window-event wx (lambda ()
(send wx on-activate #f))))))])
(define-objc-class MyWindow NSWindow
#:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
[wx])
[wxb])
(define-objc-class MyPanel NSPanel
#:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
[wx])
[wxb])
(set-front-hook! (lambda () (values front
(and front (send front get-eventspace)))))

2
collects/mred/private/wx/cocoa/gauge.rkt
View File

@ -19,7 +19,7 @@
(define-objc-class MyProgressIndicator NSProgressIndicator
#:mixins ()
[wx])
[wxb])
(defclass gauge% item%
(init parent

2
collects/mred/private/wx/cocoa/group-panel.rkt
View File

@ -16,7 +16,7 @@
(define-objc-class MyBox NSBox
#:mixins (FocusResponder KeyMouseResponder)
[wx])
[wxb])
(defclass group-panel% (panel-mixin window%)
(init parent

24
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -23,23 +23,29 @@
(define-objc-class MyTableView NSTableView
#:mixins (FocusResponder KeyMouseResponder)
[wx]
[wxb]
[-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row])
(tell (tell NSCell alloc) initTextCell: #:type _NSString (send wx get-row row))]
(let ([wx (->wx wxb)])
(tell (tell NSCell alloc) initTextCell: #:type _NSString
(if wx (send wx get-row row) "???")))]
[-a _void (doubleClicked: [_id sender])
(queue-window-event wx (lambda () (send wx clicked 'list-box-dclick)))]
(queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))]
[-a _void (tableViewSelectionDidChange: [_id aNotification])
(queue-window-event wx (lambda () (send wx clicked 'list-box)))])
(queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))])
(define-objc-class MyDataSource NSObject
#:protocols (NSTableViewDataSource)
[wx]
[wxb]
[-a _NSInteger (numberOfRowsInTableView: [_id view])
(send wx number)]
(let ([wx (->wx wxb)])
(send wx number))]
[-a _NSString (tableView: [_id aTableView]
objectValueForTableColumn: [_id aTableColumn]
row: [_NSInteger rowIndex])
(send wx get-row rowIndex)])
(let ([wx (->wx wxb)])
(if wx
(send wx get-row rowIndex)
"???"))])
(define (remove-nth data i)
(cond
@ -55,7 +61,7 @@
(define source (as-objc-allocation
(tell (tell MyDataSource alloc) init)))
(set-ivar! source wx this)
(set-ivar! source wxb (->wxb this))
(define items choices)
(define data (map (lambda (x) (box #f)) choices))
@ -73,7 +79,7 @@
(tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa)))
(init-font content-cocoa font)
content-cocoa))
(set-ivar! content-cocoa wx this)
(set-ivar! content-cocoa wxb (->wxb this))
(tellv cocoa setDocumentView: content-cocoa)
(tellv cocoa setHasVerticalScroller: #:type _BOOL #t)

9
collects/mred/private/wx/cocoa/menu-item.rkt
View File

@ -14,8 +14,11 @@
(import-class NSMenuItem)
(define-objc-class MyMenuItem NSMenuItem
[wx]
(-a _void (selected: [_id sender]) (send wx selected)))
[wxb]
(-a _void (selected: [_id sender])
(let ([wx (->wx wxb)])
(when wx
(send wx selected)))))
(defclass menu-item% object%
@ -51,7 +54,7 @@
initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "")
action: #:type _SEL #f
keyEquivalent: #:type _NSString "")])
(set-ivar! item wx this)
(set-ivar! item wxb (->wxb this))
(tellv menu addItem: item)
(tellv item setEnabled: #:type _BOOL enabled?)
(tellv item setTarget: item)

4
collects/mred/private/wx/cocoa/message.rkt
View File

@ -33,11 +33,11 @@
(define-objc-class MyTextField NSTextField
#:mixins (FocusResponder KeyMouseResponder)
[wx])
[wxb])
(define-objc-class MyImageView NSImageView
#:mixins (FocusResponder KeyMouseResponder)
[wx])
[wxb])
(defclass message% item%
(init parent label

4
collects/mred/private/wx/cocoa/radio-box.rkt
View File

@ -25,9 +25,9 @@
(define-objc-class MyMatrix NSMatrix
#:mixins (FocusResponder KeyMouseResponder)
[wx]
[wxb]
(-a _void (clicked: [_id sender])
(queue-window-event wx (lambda () (send wx clicked)))))
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(define-objc-class MyImageButtonCell NSButtonCell
[img]

14
collects/mred/private/wx/cocoa/slider.rkt
View File

@ -23,13 +23,15 @@
(define-objc-class MySlider NSSlider
#:mixins (FocusResponder KeyMouseResponder)
[wx]
[wxb]
(-a _void (changed: [_id sender])
(queue-window-event wx (lambda () (send wx changed)))
(constrained-reply
(send wx get-eventspace)
(lambda () (let loop () (pre-event-sync #t) (when (yield) (loop))))
(void))))
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda () (send wx changed)))
(constrained-reply
(send wx get-eventspace)
(lambda () (let loop () (pre-event-sync #t) (when (yield) (loop))))
(void))))))
(defclass slider% item%
(init parent cb

4
collects/mred/private/wx/cocoa/tab-panel.rkt
View File

@ -20,9 +20,9 @@
(define-objc-class MyTabView NSTabView
#:mixins (FocusResponder KeyMouseResponder)
#:protocols (NSTabViewDelegate)
[wx]
[wxb]
(-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])
(queue-window-event wx (lambda () (send wx do-callback)))))
(queue-window*-event wxb (lambda (wx) (send wx do-callback)))))
(defclass tab-panel% (panel-mixin window%)
(init parent

10
collects/mred/private/wx/cocoa/utils.rkt
View File

@ -14,7 +14,9 @@
as-objc-allocation
retain release
with-autorelease
clean-menu-label)
clean-menu-label
->wxb
->wx)
(define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa")))
(define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation")))
@ -50,3 +52,9 @@
(define (clean-menu-label str)
(regexp-replace* #rx"&(.)" str "\\1"))
(define (->wxb wx)
(make-weak-box wx))
(define (->wx wxb)
(weak-box-value wxb))

170
collects/mred/private/wx/cocoa/window.rkt
View File

@ -21,6 +21,7 @@
KeyMouseResponder
queue-window-event
queue-window*-event
request-flush-delay
cancel-flush-delay)
@ -29,30 +30,30 @@
;; ----------------------------------------
(define-objc-mixin (FocusResponder Superclass)
[wx]
[wxb]
[-a _BOOL (acceptsFirstResponder)
#t]
[-a _BOOL (becomeFirstResponder)
(and (super-tell becomeFirstResponder)
(begin
(send wx is-responder wx #t)
(let ([wx (->wx wxb)])
(when wx (send wx is-responder wx #t))
#t))]
[-a _BOOL (resignFirstResponder)
(and (super-tell resignFirstResponder)
(begin
(send wx is-responder wx #f)
(let ([wx (->wx wxb)])
(when wx (send wx is-responder wx #f))
#t))])
(define-objc-mixin (KeyMouseResponder Superclass)
[wx]
[wxb]
[-a _void (mouseDown: [_id event])
(unless (do-mouse-event wx event 'left-down #t #f #f 'right-down)
(unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down)
(super-tell #:type _void mouseDown: event))]
[-a _void (mouseUp: [_id event])
(unless (do-mouse-event wx event 'left-up #f #f #f 'right-up)
(unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up)
(super-tell #:type _void mouseUp: event))]
[-a _void (mouseDragged: [_id event])
(unless (do-mouse-event wx event 'motion #t #f #f)
(unless (do-mouse-event wxb event 'motion #t #f #f)
(super-tell #:type _void mouseDragged: event))]
[-a _void (mouseMoved: [_id event])
;; This event is sent to the first responder, instead of the
@ -69,94 +70,102 @@
(loop (tell hit superview))))))]
[-a _BOOL (doMouseMoved: [_id event])
;; called by mouseMoved:
(do-mouse-event wx event 'motion #f #f #f)]
(do-mouse-event wxb event 'motion #f #f #f)]
[-a _void (mouseEntered: [_id event])
(unless (do-mouse-event wx event 'enter #f #f #f)
(unless (do-mouse-event wxb event 'enter #f #f #f)
(super-tell #:type _void mouseEntered: event))]
[-a _void (mouseExited: [_id event])
(unless (do-mouse-event wx event 'leave #f #f #f)
(unless (do-mouse-event wxb event 'leave #f #f #f)
(super-tell #:type _void mouseExited: event))]
[-a _void (rightMouseDown: [_id event])
(unless (do-mouse-event wx event 'right-down #f #f #t)
(unless (do-mouse-event wxb event 'right-down #f #f #t)
(super-tell #:type _void rightMouseDown: event))]
[-a _void (rightMouseUp: [_id event])
(unless (do-mouse-event wx event 'right-up #f #f #f)
(unless (do-mouse-event wxb event 'right-up #f #f #f)
(super-tell #:type _void rightMouseUp: event))]
[-a _void (rightMouseDragged: [_id event])
(unless (do-mouse-event wx event 'motion #f #f #t)
(unless (do-mouse-event wxb event 'motion #f #f #t)
(super-tell #:type _void rightMouseDragged: event))]
[-a _void (otherMouseDown: [_id event])
(unless (do-mouse-event wx event 'middle-down #f #t #f)
(unless (do-mouse-event wxb event 'middle-down #f #t #f)
(super-tell #:type _void otherMouseDown: event))]
[-a _void (otherMouseUp: [_id event])
(unless (do-mouse-event wx event 'middle-up #f #f #f)
(unless (do-mouse-event wxb event 'middle-up #f #f #f)
(super-tell #:type _void otherMouseUp: event))]
[-a _void (otherMouseDragged: [_id event])
(unless (do-mouse-event wx event 'motion #f #t #f)
(unless (do-mouse-event wxb event 'motion #f #t #f)
(super-tell #:type _void otherMouseDragged: event))]
[-a _void (keyDown: [_id event])
(unless (do-key-event wx event)
(unless (do-key-event wxb event)
(super-tell #:type _void keyDown: event))]
[-a _void (insertText: [_NSString str])
(queue-window-event wx (lambda ()
(send wx key-event-as-string str)))])
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda ()
(send wx key-event-as-string str)))))])
(define (do-key-event wx event)
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)]
[str (tell #:type _NSString event characters)])
(let-values ([(x y) (send wx window-point-to-view pos)])
(let ([k (new key-event%
[key-code (or
(map-key-code (tell #:type _ushort event keyCode))
(if (string=? "" str)
#\nul
(string-ref str 0)))]
[shift-down (bit? modifiers NSShiftKeyMask)]
[control-down (bit? modifiers NSControlKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)]
[x (->long x)]
[y (->long y)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(if (send wx definitely-wants-event? k)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-char k #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t))
#t))))))
(define (do-key-event wxb event)
(let ([wx (->wx wxb)])
(and
wx
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)]
[str (tell #:type _NSString event characters)])
(let-values ([(x y) (send wx window-point-to-view pos)])
(let ([k (new key-event%
[key-code (or
(map-key-code (tell #:type _ushort event keyCode))
(if (string=? "" str)
#\nul
(string-ref str 0)))]
[shift-down (bit? modifiers NSShiftKeyMask)]
[control-down (bit? modifiers NSControlKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)]
[x (->long x)]
[y (->long y)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(if (send wx definitely-wants-event? k)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-char k #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t))
#t))))))))
(define (do-mouse-event wx event kind l? m? r? [ctl-kind kind])
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)])
(let-values ([(x y) (send wx window-point-to-view pos)]
[(control-down) (bit? modifiers NSControlKeyMask)])
(let ([m (new mouse-event%
[event-type (if control-down ctl-kind kind)]
[left-down (and l? (not control-down))]
[middle-down m?]
[right-down (or r? (and l? control-down))]
[x (->long x)]
[y (->long y)]
[shift-down (bit? modifiers NSShiftKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(if (send wx definitely-wants-event? m)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-event m #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-event m #t))
#t))))))
(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind])
(let ([wx (->wx wxb)])
(and
wx
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)])
(let-values ([(x y) (send wx window-point-to-view pos)]
[(control-down) (bit? modifiers NSControlKeyMask)])
(let ([m (new mouse-event%
[event-type (if control-down ctl-kind kind)]
[left-down (and l? (not control-down))]
[middle-down m?]
[right-down (or r? (and l? control-down))]
[x (->long x)]
[y (->long y)]
[shift-down (bit? modifiers NSShiftKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(if (send wx definitely-wants-event? m)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-event m #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-event m #t))
#t))))))))
(define window%
(class object%
@ -173,7 +182,7 @@
(when (eventspace-shutdown? eventspace)
(error '|GUI object initialization| "the eventspace has been shutdown"))
(set-ivar! cocoa wx this)
(set-ivar! cocoa wxb (->wxb this))
(unless no-show?
(show #t))
@ -392,8 +401,13 @@
;; ----------------------------------------
(define (queue-window-event win thunk)
(queue-event (send win get-eventspace) thunk))
(define (queue-window-event wx thunk)
(queue-event (send wx get-eventspace) thunk))
(define (queue-window*-event wxb proc)
(let ([wx (->wx wxb)])
(when wx
(queue-event (send wx get-eventspace) (lambda () (proc wx))))))
(define depth 0)

3
collects/mred/private/wx/gtk/button.rkt
View File

@ -29,7 +29,8 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx queue-clicked))))
(when wx
(send wx queue-clicked)))))
(defclass button-core% item%
(init parent cb label x y w h style font

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

@ -121,7 +121,8 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx combo-maybe-clicked))))
(when wx
(send wx combo-maybe-clicked)))))
(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
@ -130,11 +131,12 @@
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(unless (send wx paint-or-queue-paint)
(let ([gc (send wx get-canvas-background-for-clearing)])
(when gc
(gdk_draw_rectangle (widget-window gtk) gc #t
0 0 32000 32000)))))
(when wx
(unless (send wx paint-or-queue-paint)
(let ([gc (send wx get-canvas-background-for-clearing)])
(when gc
(gdk_draw_rectangle (widget-window gtk) gc #t
0 0 32000 32000))))))
#t))
(define-signal-handler connect-expose-border "expose-event"
@ -165,7 +167,8 @@
(define (do-value-changed gtk dir)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda () (send wx do-scroll dir))))
(when wx
(queue-window-event wx (lambda () (send wx do-scroll dir)))))
#t)
(define-gtk gtk_entry_get_type (_fun -> _GType))

3
collects/mred/private/wx/gtk/choice.rkt
View File

@ -26,7 +26,8 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx queue-clicked))))
(when wx
(send wx queue-clicked)))))
(defclass choice% item%
(init parent cb label

11
collects/mred/private/wx/gtk/client-window.rkt
View File

@ -17,11 +17,12 @@
(_fun _GtkWidget _GtkAllocation-pointer -> _gboolean)
(lambda (gtk a)
(let ([wx (gtk->wx gtk)])
(send wx save-client-size
(GtkAllocation-x a)
(GtkAllocation-y a)
(GtkAllocation-width a)
(GtkAllocation-height a)))
(when wx
(send wx save-client-size
(GtkAllocation-x a)
(GtkAllocation-y a)
(GtkAllocation-width a)
(GtkAllocation-height a))))
#t))
(define (client-size-mixin %)

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

@ -56,18 +56,20 @@
(_fun _GtkWidget -> _gboolean)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda ()
(unless (other-modal? wx)
(when (send wx on-close)
(send wx direct-show #f))))))))
(when wx
(queue-window-event wx (lambda ()
(unless (other-modal? wx)
(when (send wx on-close)
(send wx direct-show #f)))))))))
(define-signal-handler connect-configure "configure-event"
(_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean)
(lambda (gtk a)
(let ([wx (gtk->wx gtk)])
(send wx remember-size
(GdkEventConfigure-width a)
(GdkEventConfigure-height a)))
(when wx
(send wx remember-size
(GdkEventConfigure-width a)
(GdkEventConfigure-height a))))
#f))
(define-cstruct _GdkEventWindowState ([type _int]
@ -81,9 +83,10 @@
(_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean)
(lambda (gtk evt)
(let ([wx (gtk->wx gtk)])
(send wx on-window-state
(GdkEventWindowState-changed_mask evt)
(GdkEventWindowState-new_window_state evt)))
(when wx
(send wx on-window-state
(GdkEventWindowState-changed_mask evt)
(GdkEventWindowState-new_window_state evt))))
#f))
(define frame%

3
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -62,7 +62,8 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx queue-changed))))
(when wx
(send wx queue-changed)))))
(defclass list-box% item%
(init parent cb

17
collects/mred/private/wx/gtk/menu-bar.rkt
View File

@ -41,11 +41,12 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(let ([frame (send wx get-top-window)])
(when frame
(constrained-reply (send frame get-eventspace)
(lambda () (send frame on-menu-click))
(void)))))))
(when wx
(let ([frame (send wx get-top-window)])
(when frame
(constrained-reply (send frame get-eventspace)
(lambda () (send frame on-menu-click))
(void))))))))
(define top-menu%
(class widget%
@ -57,13 +58,15 @@
(_fun _GtkWidget _GdkEventKey-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(other-modal? wx))))
(or (not wx)
(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))))
(or (not wx)
(other-modal? wx)))))
(defclass menu-bar% widget%
(inherit install-widget-parent)

6
collects/mred/private/wx/gtk/menu.rkt
View File

@ -36,13 +36,15 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx do-on-select))))
(when wx
(send wx do-on-select)))))
(define-signal-handler connect-menu-deactivate "deactivate"
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx do-no-selected))))
(when wx
(send wx do-no-selected)))))
(define menu-item-handler%
(class widget%

3
collects/mred/private/wx/gtk/radio-box.rkt
View File

@ -31,7 +31,8 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx queue-clicked))))
(when wx
(send wx queue-clicked)))))
(defclass radio-box% item%
(init parent cb label

3
collects/mred/private/wx/gtk/slider.rkt
View File

@ -26,7 +26,8 @@
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(send wx queue-changed))))
(when wx
(send wx queue-changed)))))
(defclass slider% item%
(init parent cb

3
collects/mred/private/wx/gtk/tab-panel.rkt
View File

@ -35,7 +35,8 @@
(_fun _GtkWidget _pointer _int -> _void)
(lambda (gtk ignored i)
(let ([wx (gtk->wx gtk)])
(send wx page-changed i))))
(when wx
(send wx page-changed i)))))
(define tab-panel%
(class (client-size-mixin (panel-mixin window%))

6
collects/mred/private/wx/gtk/widget.rkt
View File

@ -52,14 +52,16 @@
(super-new)
(let ([cell (malloc-immobile-cell this)])
(let ([cell (malloc-immobile-cell (make-weak-box this))])
(g_object_set_data gtk "wx" cell)
(for ([gtk (in-list extra-gtks)])
(g_object_set_data gtk "wx" cell)))))
(define (gtk->wx gtk)
(let ([ptr (g_object_get_data gtk "wx")])
(and ptr (ptr-ref ptr _scheme))))
(and ptr
(let ([wb (ptr-ref ptr _scheme)])
(and wb (weak-box-value wb))))))
(set-widget-hook! (lambda (gtk)
(let loop ([gtk gtk])

195
collects/mred/private/wx/gtk/window.rkt
View File

@ -81,13 +81,15 @@
(_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda () (send wx on-set-focus)))
(when wx
(queue-window-event wx (lambda () (send wx on-set-focus))))
#f)))
(define-signal-handler connect-focus-out "focus-out-event"
(_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda () (send wx on-kill-focus)))
(when wx
(queue-window-event wx (lambda () (send wx on-kill-focus))))
#f)))
(define (connect-focus gtk)
(connect-focus-in gtk)
@ -97,47 +99,52 @@
(_fun _GtkWidget _GtkAllocation-pointer -> _gboolean)
(lambda (gtk a)
(let ([wx (gtk->wx gtk)])
(send wx save-size
(GtkAllocation-x a)
(GtkAllocation-y a)
(GtkAllocation-width a)
(GtkAllocation-height a)))
(when wx
(send wx save-size
(GtkAllocation-x a)
(GtkAllocation-y a)
(GtkAllocation-width a)
(GtkAllocation-height a))))
#t))
;; ----------------------------------------
(define-signal-handler connect-key-press "key-press-event"
(_fun _GtkWidget _GdkEventKey-pointer -> _gboolean)
(lambda (gtk event)
(let* ([wx (gtk->wx gtk)]
[modifiers (GdkEventKey-state event)]
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
[k (new key-event%
[key-code (let ([kv (GdkEventKey-keyval event)])
(or
(map-key-code kv)
(integer->char (gdk_keyval_to_unicode kv))))]
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
[control-down (bit? modifiers GDK_CONTROL_MASK)]
[meta-down (bit? modifiers GDK_META_MASK)]
[alt-down (bit? modifiers GDK_MOD1_MASK)]
[x 0]
[y 0]
[time-stamp (GdkEventKey-time event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
(if (send wx handles-events? gtk)
(begin
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t))
#t)))))
(let ([wx (gtk->wx gtk)])
(and
wx
(let* ([modifiers (GdkEventKey-state event)]
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
[k (new key-event%
[key-code (let ([kv (GdkEventKey-keyval event)])
(or
(map-key-code kv)
(integer->char (gdk_keyval_to_unicode kv))))]
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
[control-down (bit? modifiers GDK_CONTROL_MASK)]
[meta-down (bit? modifiers GDK_META_MASK)]
[alt-down (bit? modifiers GDK_MOD1_MASK)]
[x 0]
[y 0]
[time-stamp (GdkEventKey-time event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
(if (send wx handles-events? gtk)
(begin
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t))
#t)))))))
(define-signal-handler connect-button-press "button-press-event"
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
(lambda (gtk event)
(unless (gtk_widget_is_focus gtk)
(unless (other-modal? (gtk->wx gtk))
(gtk_widget_grab_focus gtk)))
(let ([wx (gtk->wx gtk)])
(when wx
(unless (other-modal? wx)
(gtk_widget_grab_focus gtk)))))
(do-button-event gtk event #f #f)))
(define-signal-handler connect-button-release "button-release-event"
@ -176,67 +183,69 @@
(GdkEventButton-type event)))])
(unless (or (= type GDK_2BUTTON_PRESS)
(= type GDK_3BUTTON_PRESS))
(let* ([wx (gtk->wx gtk)]
[modifiers (if motion?
(GdkEventMotion-state event)
(if crossing?
(GdkEventCrossing-state event)
(GdkEventButton-state event)))]
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
[type (cond
[(= type GDK_MOTION_NOTIFY)
'motion]
[(= type GDK_ENTER_NOTIFY)
'enter]
[(= type GDK_LEAVE_NOTIFY)
'leave]
[(= type GDK_BUTTON_PRESS)
(case (GdkEventButton-button event)
[(1) 'left-down]
[(3) 'right-down]
[else 'middle-down])]
[else
(case (GdkEventButton-button event)
[(1) 'left-up]
[(3) 'right-up]
[else 'middle-up])])]
[m (new mouse-event%
[event-type type]
[left-down (case type
[(left-down) #t]
[(left-up) #f]
[else (bit? modifiers GDK_BUTTON1_MASK)])]
[middle-down (case type
[(middle-down) #t]
[(middle-up) #f]
[else (bit? modifiers GDK_BUTTON2_MASK)])]
[right-down (case type
[(right-down) #t]
[(right-up) #f]
[else (bit? modifiers GDK_BUTTON3_MASK)])]
[x (->long ((if motion?
GdkEventMotion-x
(if crossing? GdkEventCrossing-x GdkEventButton-x))
event))]
[y (->long ((if motion? GdkEventMotion-y
(if crossing? GdkEventCrossing-y GdkEventButton-y))
event))]
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
[control-down (bit? modifiers GDK_CONTROL_MASK)]
[meta-down (bit? modifiers GDK_META_MASK)]
[alt-down (bit? modifiers GDK_MOD1_MASK)]
[time-stamp ((if motion? GdkEventMotion-time
(if crossing? GdkEventCrossing-time GdkEventButton-time))
event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
(if (send wx handles-events? gtk)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-event m #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-event m #t))
#t))))))
(let ([wx (gtk->wx gtk)])
(and
wx
(let* ([modifiers (if motion?
(GdkEventMotion-state event)
(if crossing?
(GdkEventCrossing-state event)
(GdkEventButton-state event)))]
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
[type (cond
[(= type GDK_MOTION_NOTIFY)
'motion]
[(= type GDK_ENTER_NOTIFY)
'enter]
[(= type GDK_LEAVE_NOTIFY)
'leave]
[(= type GDK_BUTTON_PRESS)
(case (GdkEventButton-button event)
[(1) 'left-down]
[(3) 'right-down]
[else 'middle-down])]
[else
(case (GdkEventButton-button event)
[(1) 'left-up]
[(3) 'right-up]
[else 'middle-up])])]
[m (new mouse-event%
[event-type type]
[left-down (case type
[(left-down) #t]
[(left-up) #f]
[else (bit? modifiers GDK_BUTTON1_MASK)])]
[middle-down (case type
[(middle-down) #t]
[(middle-up) #f]
[else (bit? modifiers GDK_BUTTON2_MASK)])]
[right-down (case type
[(right-down) #t]
[(right-up) #f]
[else (bit? modifiers GDK_BUTTON3_MASK)])]
[x (->long ((if motion?
GdkEventMotion-x
(if crossing? GdkEventCrossing-x GdkEventButton-x))
event))]
[y (->long ((if motion? GdkEventMotion-y
(if crossing? GdkEventCrossing-y GdkEventButton-y))
event))]
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
[control-down (bit? modifiers GDK_CONTROL_MASK)]
[meta-down (bit? modifiers GDK_META_MASK)]
[alt-down (bit? modifiers GDK_MOD1_MASK)]
[time-stamp ((if motion? GdkEventMotion-time
(if crossing? GdkEventCrossing-time GdkEventButton-time))
event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
(if (send wx handles-events? gtk)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-event m #f)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-event m #t))
#t))))))))
;; ----------------------------------------