diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 12999b1acf..29365d24df 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -41,35 +41,40 @@ (define/public (set-enabled-flag e?) (set! enabled? e?)) (define/public (get-enabled-flag) enabled?) + (define submenu #f) + (define/public (set-submenu m) (set! submenu m)) + (define/public (install menu) - (let ([item (tell (tell MyMenuItem alloc) - initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") - action: #:type _SEL #f - keyEquivalent: #:type _NSString "")]) - (set-ivar! item wx this) - (tellv menu addItem: item) - (tellv item setEnabled: #:type _BOOL enabled?) - (tellv item setTarget: item) - (tellv item setAction: #:type _SEL (selector selected:)) - (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) - (when shortcut - (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] - [flags (- (char->integer (string-ref (cadr shortcut) 0)) - (char->integer #\A))] - [mods (+ (if (positive? (bitwise-and flags 1)) - NSShiftKeyMask - 0) - (if (positive? (bitwise-and flags 2)) - NSAlternateKeyMask - 0) - (if (positive? (bitwise-and flags 4)) - NSControlKeyMask - 0) - (if (positive? (bitwise-and flags 8)) - 0 - NSCommandKeyMask))]) - (tellv item setKeyEquivalent: #:type _NSString s) - (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) - (tellv item release))) + (if submenu + (send submenu install menu label) + (let ([item (tell (tell MyMenuItem alloc) + initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") + action: #:type _SEL #f + keyEquivalent: #:type _NSString "")]) + (set-ivar! item wx this) + (tellv menu addItem: item) + (tellv item setEnabled: #:type _BOOL enabled?) + (tellv item setTarget: item) + (tellv item setAction: #:type _SEL (selector selected:)) + (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) + (when shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) + (tellv item release)))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 804254c134..ccd373137c 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -17,6 +17,9 @@ (define-struct mitem (item)) +(define (clean-label str) + (regexp-replace* #rx"&(.)" str "\\1")) + (defclass menu% object% (init-field label callback @@ -34,13 +37,13 @@ (set! cocoa (as-objc-allocation (tell (tell NSMenuItem alloc) - initWithTitle: #:type _NSString label + initWithTitle: #:type _NSString (clean-label label) action: #:type _SEL #f keyEquivalent: #:type _NSString ""))) (set! cocoa-menu (as-objc-allocation (tell (tell NSMenu alloc) - initWithTitle: #:type _NSString label))) + initWithTitle: #:type _NSString (clean-label label)))) (tellv cocoa-menu setAutoenablesItems: #:type _BOOL #f) (tellv cocoa setSubmenu: cocoa-menu) (for-each (lambda (item) @@ -94,8 +97,11 @@ (send parent get-top-window)))) (public [append-item append]) - (define (append-item i label help-str chckable?) + (define (append-item i label help-str-or-submenu chckable?) (send i set-label label) + (when (help-str-or-submenu . is-a? . menu%) + (send i set-submenu help-str-or-submenu) + (send help-str-or-submenu set-parent this)) (set! items (append items (list (make-mitem i)))) (send i set-parent this) (when cocoa-menu @@ -131,9 +137,9 @@ (define/public (set-label item label) (adjust item (lambda (item-cocoa) - (tellv item-cocoa setTitle: #:type _NSString label)) + (tellv item-cocoa setTitle: #:type _NSString (clean-label label))) (lambda (mitem) - (send (mitem-item mitem) set-label label)))) + (send (mitem-item mitem) set-label (clean-label label))))) (define/public (check item on?) (adjust item diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 0437014ca8..6edf6fd04d 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -117,6 +117,12 @@ 0 (set-focus))) + (define/public (enable-button i on?) + (tellv (tell (get-cocoa) + cellAtRow: #:type _NSUInteger (if horiz? 0 i) + column: #:type _NSUInteger (if horiz? i 0)) + setEnabled: #:type _BOOL on?)) + (define/public (set-selection i) (if (= i -1) (begin diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 52dfe4e5f5..0f371ad8de 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -33,14 +33,23 @@ "_\\1") "&")) -(define-signal-handler connect-button-press "button-press-event" - (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) - (lambda (gtk event) +(define-signal-handler connect-select "select" + (_fun _GtkWidget -> _void) + (lambda (gtk) (let ([wx (gtk->wx gtk)]) (let ([frame (send wx get-top-window)]) - (constrained-reply (send wx get-eventspace) - (lambda () (send frame on-menu-click) #f) - #t))))) + (when frame + (constrained-reply (send frame get-eventspace) + (lambda () (send frame on-menu-click)) + (void))))))) + +(define top-menu% + (class widget% + (init-field parent) + (define/public (get-top-window) (send parent get-top-window)) + (super-new))) + + (defclass menu-bar% widget% (define menus null) @@ -48,8 +57,6 @@ (define gtk (gtk_menu_bar_new)) (super-new [gtk gtk]) - (connect-button-press gtk) - (define/public (get-gtk) gtk) (define top-wx #f) @@ -83,8 +90,10 @@ (public [append-menu append]) (define (append-menu menu title) (send menu set-parent this) - (let ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]) - (set! menus (append menus (list (list item menu)))) + (let* ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))] + [item-wx (new top-menu% [parent this] [gtk item])]) + (connect-select item) + (set! menus (append menus (list (list item menu item-wx)))) (let ([gtk (send menu get-gtk)]) (g_object_ref gtk) (gtk_menu_item_set_submenu item gtk)) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 6b6a0c63fb..f5cf82474d 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -25,6 +25,7 @@ (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_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_get_current_event_time (_fun -> _uint32)) (define-gtk gtk_menu_popup (_fun _GtkWidget _pointer _pointer @@ -55,12 +56,20 @@ (define/public (get-item) menu-item) + (define/public (removing-item) (void)) + (define/public (do-on-select) (send menu do-selected menu-item)) (define/public (on-select) (send menu on-select-item menu-item)))) +(define separator-item-handler% + (class object% + (define/public (get-item) #f) + (define/public (removing-item) (void)) + (super-new))) + (defclass menu% widget% (init label callback @@ -87,6 +96,15 @@ (send parent get-top-parent) (send parent get-top-window)))) + (define self-item #f) + (define remover void) + (define/public (set-self-item i r) (set! self-item i) (set! remover r)) + (define/public (get-item) self-item) + (define/public (removing-item) + (set! self-item #f) + (remover) + (set! remover void)) + (define on-popup #f) (define cancel-none-box (box #t)) @@ -152,23 +170,32 @@ (gtk_menu_item_set_accel_path item-gtk accel-path)))))])) (public [append-item append]) - (define (append-item i label help-str chckable?) - (let* ([item-gtk ((if chckable? - gtk_check_menu_item_new_with_mnemonic - gtk_menu_item_new_with_mnemonic) - (fixup-mneumonic label))] - [item (new menu-item-handler% - [gtk item-gtk] - [menu this] - [menu-item i])]) - (set! items (append items (list (list item item-gtk label chckable?)))) - (adjust-shortcut item-gtk label) + (define (append-item i label help-str-or-submenu chckable?) + (let ([item-gtk ((if chckable? + gtk_check_menu_item_new_with_mnemonic + gtk_menu_item_new_with_mnemonic) + (fixup-mneumonic label))]) + (if (help-str-or-submenu . is-a? . menu%) + (let ([submenu help-str-or-submenu]) + (let ([gtk (send submenu get-gtk)]) + (g_object_ref gtk) + (gtk_menu_item_set_submenu item-gtk gtk) + (send submenu set-parent this) + (send submenu set-self-item i + (lambda () (gtk_menu_item_set_submenu item-gtk #f))) + (set! items (append items (list (list submenu item-gtk label chckable?)))))) + (let ([item (new menu-item-handler% + [gtk item-gtk] + [menu this] + [menu-item i])]) + (set! items (append items (list (list item item-gtk label chckable?)))) + (adjust-shortcut item-gtk label))) (gtk_menu_shell_append gtk item-gtk) (gtk_widget_show item-gtk))) (define/public (append-separator) (let ([item-gtk (gtk_separator_menu_item_new)]) - (set! items (append items (list (list #f item-gtk #f #f)))) + (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f)))) (gtk_menu_shell_append gtk item-gtk) (gtk_widget_show item-gtk))) @@ -214,6 +241,7 @@ (cond [(null? items) null] [(zero? pos) + (send (caar items) removing-item) (gtk_container_remove gtk (cadar items)) (cdr items)] [else (cons (car items) @@ -225,6 +253,7 @@ (cond [(null? items) null] [(eq? (send (caar items) get-item) item) + (send (caar items) removing-item) (gtk_container_remove gtk (cadar items)) (cdr items)] [else (cons (car items) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index d113b26979..4a1466a264 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -120,5 +120,8 @@ i)) -1)) + (define/public (enable-button i on?) + (gtk_widget_set_sensitive (list-ref radio-gtks i) on?)) + (define count (length labels)) (define/public (number) count)) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 536ecae71f..597b3a62fe 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -233,6 +233,11 @@ major (filter-style style) font)) (set-c c) + (define/override enable + (case-lambda + [(on?) (super enable on?)] + [(i on?) (send c enable-button i on?)])) + (bounce c (button-focus i)