diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 7bf877cade..804254c134 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -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)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index cde3f9e520..5a470bf682 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -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) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index 793c18de11..36ff6e7800 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -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] diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 8e3c0ecbdb..23a4cec8dc 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -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) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 9335040eb5..6b6a0c63fb 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -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)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 7e9f50bee6..eb5e3ce350 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -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)))