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

submenus

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-02 10:32:13 -06:00
parent 06a47a3c54
commit 6ae09fca1c
7 changed files with 119 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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))

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

@ -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

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

@ -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

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

@ -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))

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

@ -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)

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

@ -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))

5
collects/mred/private/wxlitem.rkt
View File

@ -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)