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

popup menus

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-28 10:14:54 -05:00
parent 82c0a1cc29
commit bc7d3d7376
6 changed files with 174 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mred/private/wx/cocoa/menu.rkt
View File

@ -3,10 +3,11 @@
scheme/foreign
(only-in scheme/list drop take)
ffi/objc
"../../syntax.rkt"
"utils.rkt"
"types.rkt"
"window.rkt")
"../common/event.rkt"
"../../syntax.rkt"
"utils.rkt"
"types.rkt"
"window.rkt")
(unsafe!)
(objc-unsafe!)
@ -28,7 +29,7 @@
(define cocoa #f)
(define cocoa-menu #f)
(define/public (install cocoa-parent label)
(define/public (create-menu label)
(unless cocoa
(set! cocoa
(as-objc-allocation
@ -46,16 +47,42 @@
(if item
(send (mitem-item item) install cocoa-menu)
(tellv cocoa-menu addItem: (tell NSMenuItem separatorItem))))
items))
items)))
(define/public (install cocoa-parent label)
(create-menu label)
(tellv cocoa-parent addItem: cocoa))
(define popup-box #f)
(define/public (do-popup v x y queue-cb)
(unless (null? items)
(create-menu "menu")
(let ([b (box #f)])
(set! popup-box b)
(tellv cocoa-menu
popUpMenuPositioningItem: (tell cocoa-menu itemAtIndex: #:type _NSUInteger 0)
atLocation: #:type _NSPoint (make-NSPoint x y)
inView: v)
(set! popup-box #f)
(let* ([i (unbox b)]
[e (new popup-event% [event-type 'menu-popdown])])
(send e set-menu-id i)
(queue-cb (lambda () (callback this e)))))))
(define/public (item-selected menu-item)
;; called in Cocoa thread
(let ([top (get-top-parent)])
(when top
(queue-window-event
top
(lambda () (send top on-menu-command menu-item))))))
(cond
[popup-box
(set-box! popup-box menu-item)]
[(parent . is-a? . menu%)
(send parent item-selected menu-item)]
[else
(let ([top (get-top-parent)])
(when top
(queue-window-event
top
(lambda () (send top on-menu-command menu-item)))))]))
(define parent #f)
(define/public (set-parent p) (set! parent p))

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

@ -40,10 +40,10 @@
(define-objc-mixin (KeyMouseResponder Superclass)
[wx]
[-a _void (mouseDown: [_id event])
(unless (do-mouse-event wx event 'left-down #t #f #f)
(unless (do-mouse-event wx 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)
(unless (do-mouse-event wx 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)
@ -112,20 +112,20 @@
(lambda () (send wx dispatch-on-char k #t))
#t))))))
(define (do-mouse-event wx event kind l? m? r?)
(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)])
(let-values ([(x y) (send wx window-point-to-view pos)]
[(control-down) (bit? modifiers NSControlKeyMask)])
(let ([m (new mouse-event%
[event-type kind]
[left-down l?]
[event-type (if control-down ctl-kind kind)]
[left-down (and l? (not control-down))]
[middle-down m?]
[right-down r?]
[right-down (or r? (and l? control-down))]
[x (->long x)]
[y (->long y)]
[shift-down (bit? modifiers NSShiftKeyMask)]
[control-down (bit? modifiers NSControlKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
@ -312,7 +312,12 @@
(def/public-unimplemented on-drop-file)
(def/public-unimplemented get-handle)
(def/public-unimplemented set-phantom-size)
(def/public-unimplemented popup-menu)
(define/public (popup-menu m x y)
(send m do-popup (get-cocoa-content) x (flip-client y)
(lambda (thunk)
(queue-window-event this thunk))))
(define/public (center a b) (void))
(def/public-unimplemented refresh)

6
collects/mred/private/wx/common/event.rkt
View File

@ -91,7 +91,8 @@
(init-properties [[(symbol-in button check-box choice
list-box list-box-dclick text-field
text-field-enter slider radio-box
menu-popdown menu-popdown-none tab-panel)
menu-popdown menu-popdown-none tab-panel
menu)
event-type]
;; FIXME: should have no default
'button])
@ -99,7 +100,8 @@
(super-new [time-stamp time-stamp]))
(defclass popup-event% control-event%
(properties [[any? menu-id] 0]))
(properties [[any? menu-id] 0])
(super-new))
(defclass scroll-event% event%
(init-properties [[(symbol-in top bottom line-up line-down page-up page-down thumb) event-type]

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

@ -27,6 +27,9 @@
(define-gtk gtk_window_maximize (_fun _GtkWidget -> _void))
(define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void))
(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void))
(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int))
-> _void
-> (values x y)))
(define (handle-delete gtk)
(let ([wx (gtk->wx gtk)])
@ -162,7 +165,9 @@
(pre-on-char w e))
(define/override (client-to-screen x y)
(void))
(let-values ([(dx dy) (gtk_window_get_position gtk)])
(set-box! x (+ (unbox x) dx))
(set-box! y (+ (unbox y) dy))))
(def/public-unimplemented on-toolbar-click)
(def/public-unimplemented on-menu-click)

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

@ -7,7 +7,8 @@
"types.rkt"
"const.rkt"
"utils.rkt"
"menu-bar.rkt")
"menu-bar.rkt"
"../common/event.rkt")
(unsafe!)
(provide menu%)
@ -22,6 +23,14 @@
(define-gtk gtk_check_menu_item_get_active (_fun _GtkWidget -> _gboolean))
(define-gtk gtk_menu_item_set_label (_fun _GtkWidget _string -> _void))
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
(define-gtk gtk_get_current_event_time (_fun -> _uint32))
(define-gtk gtk_menu_popup (_fun _GtkWidget _pointer _pointer
(_fun _GtkWidget _pointer _pointer _pointer -> _void)
_pointer _uint _uint32
-> _void))
(define-signal-handler connect-menu-item-activate "activate"
(_fun _GtkWidget -> _void)
@ -29,6 +38,12 @@
(let ([wx (gtk->wx gtk)])
(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))))
(define menu-item-handler%
(class widget%
(init gtk)
@ -41,11 +56,7 @@
(define/public (get-item) menu-item)
(define/public (do-on-select)
(let ([top (send menu get-top-parent)])
(when top
(queue-window-event
top
(lambda () (send top on-menu-command menu-item))))))
(send menu do-selected menu-item))
(define/public (on-select)
(send menu on-select-item menu-item))))
@ -55,11 +66,15 @@
callback
font)
(define cb callback)
(define gtk (gtk_menu_new))
(define/public (get-gtk) gtk)
(super-new [gtk gtk])
(connect-menu-deactivate gtk)
(define items null)
(define parent #f)
@ -72,6 +87,56 @@
(send parent get-top-parent)
(send parent get-top-window))))
(define on-popup #f)
(define cancel-none-box (box #t))
(define/public (popup x y queue-cb)
(set! on-popup queue-cb)
(set! cancel-none-box (box #f))
(gtk_menu_popup gtk
#f
#f
(lambda (menu _x _y _push)
(ptr-set! _x _int x)
(ptr-set! _y _int y)
(ptr-set! _push _gboolean #t))
#f
0
(gtk_get_current_event_time)))
(define/public (do-selected menu-item)
;; Called in event-pump thread
(let ([top (get-top-parent)])
(cond
[top
(queue-window-event
top
(lambda () (send top on-menu-command menu-item)))]
[on-popup
(let* ([e (new popup-event% [event-type 'menu-popdown])]
[pu on-popup]
[cnb cancel-none-box])
(set! on-popup #f)
(set-box! cancel-none-box #t)
(send e set-menu-id menu-item)
(pu (lambda () (cb this e))))]
[parent (send parent do-selected menu-item)])))
(define/public (do-no-selected)
;; Queue a none-selected event, but only tentatively, because
;; the selection event may come later and cancel the none-selected
;; event.
(when on-popup
(let* ([e (new popup-event% [event-type 'menu-popdown])]
[pu on-popup]
[cnb cancel-none-box])
(send e set-menu-id #f)
(pu (lambda ()
(when (eq? on-popup pu)
(set! on-popup #f))
(unless (unbox cnb)
(cb this e)))))))
(define/private (adjust-shortcut item-gtk title)
(cond
[(regexp-match #rx"\tCtrl[+](.)$" title)
@ -124,7 +189,8 @@
(define/public (set-label item str)
(let ([gtk (find-gtk item)])
(when gtk
(gtk_menu_item_set_label gtk str))))
(gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk)
(fixup-mneumonic str)))))
(define/public (enable item on?)
(let ([gtk (find-gtk item)])

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

@ -153,27 +153,37 @@
(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 (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])])]
[left-down (bit? modifiers GDK_BUTTON1_MASK)]
[middle-down (bit? modifiers GDK_BUTTON2_MASK)]
[right-down (bit? modifiers GDK_BUTTON2_MASK)]
[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))
@ -338,7 +348,14 @@
(def/public-unimplemented on-drop-file)
(def/public-unimplemented get-handle)
(def/public-unimplemented set-phantom-size)
(def/public-unimplemented popup-menu)
(define/public (popup-menu m x y)
(let ([gx (box x)]
[gy (box y)])
(client-to-screen gx gy)
(send m popup (unbox gx) (unbox gy)
(lambda (thunk) (queue-window-event this thunk)))))
(define/public (center a b) (void))
(define/public (refresh) (void))
@ -349,7 +366,7 @@
(set-box! x (- (unbox x) (unbox xb)))
(set-box! y (- (unbox y) (unbox yb)))))
(define/public (client-to-screen x y)
(send parent screen-to-client x y)
(send parent client-to-screen x y)
(set-box! x (+ (unbox x) save-x))
(set-box! y (+ (unbox y) save-y)))