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

.

Browse Source 
original commit: f9847b200671d1c5f825c73fde40193ea9c0cebd
This commit is contained in:
Matthew Flatt 1999-07-05 13:24:29 +00:00
parent 7c18fdf6ad
commit c3cde79d5e
1 changed files with 29 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
src/mred/wrap/mred.ss
View File

@ -3620,7 +3620,8 @@
(class* wx:menu-item% (wx<%>) (mred menu-data) (class* wx:menu-item% (wx<%>) (mred menu-data)
(private (private
[keymap #f] [keymap #f]
[wx-menu #f]) [wx-menu #f]
[enabled? #t])
(public (public
[get-keymap (lambda () keymap)] [get-keymap (lambda () keymap)]
[set-keymap (lambda (k) (set! keymap k))] [set-keymap (lambda (k) (set! keymap k))]
@ -3630,7 +3631,9 @@
[get-mred (lambda () mred)] [get-mred (lambda () mred)]
[get-menu-data (lambda () menu-data)] ; for meta-shortcuts [get-menu-data (lambda () menu-data)] ; for meta-shortcuts
[get-container (lambda () wx-menu)] [get-container (lambda () wx-menu)]
[set-wx-menu (lambda (wx) (set! wx-menu wx))]) [set-wx-menu (lambda (wx) (set! wx-menu wx))]
[is-enabled? (lambda () enabled?)]
[set-enabled (lambda (on?) (set! enabled? on?))])
(sequence (sequence
(super-init)))) (super-init))))
@ -3675,7 +3678,8 @@
(when disabled? (when disabled?
(super-enable-top (length items) #f)) (super-enable-top (length items) #f))
(set! items (append items (list item))) (set! items (append items (list item)))
(send keymap chain-to-keymap (send (mred->wx item) get-keymap) #f))] (when (send (mred->wx item) is-enabled?)
(send keymap chain-to-keymap (send (mred->wx item) get-keymap) #f)))]
[all-enabled? (lambda () (not disabled?))] [all-enabled? (lambda () (not disabled?))]
[enable-all (lambda (on?) [enable-all (lambda (on?)
(set! disabled? (not on?)) (set! disabled? (not on?))
@ -3697,12 +3701,14 @@
[enable-top (lambda (p on?) [enable-top (lambda (p on?)
(let ([i (list-ref items p)]) (let ([i (list-ref items p)])
(if on? (if on?
(begin (when (memq i disabled)
(set! disabled (remq i disabled)) (set! disabled (remq i disabled))
(send keymap add-chained-keymap (send (mred->wx i) get-keymap) #t)
(unless disabled? (unless disabled?
(super-enable-top p #t))) (super-enable-top p #t)))
(unless (memq i disabled) (unless (memq i disabled)
(set! disabled (cons i disabled)) (set! disabled (cons i disabled))
(send keymap remove-chained-keymap (send (mred->wx i) get-keymap))
(super-enable-top p #f)))))]) (super-enable-top p #f)))))])
(sequence (sequence
(super-init null null)))) (super-init null null))))
@ -3713,7 +3719,8 @@
[items null] [items null]
[keymap (make-object wx:keymap%)]) [keymap (make-object wx:keymap%)])
(inherit delete-by-position) (inherit delete-by-position)
(rename [super-delete delete]) (rename [super-delete delete]
[super-enable enable])
(public (public
[get-container (lambda () this)] [get-container (lambda () this)]
[get-keymap (lambda () keymap)] [get-keymap (lambda () keymap)]
@ -3721,7 +3728,8 @@
[get-items (lambda () items)] [get-items (lambda () items)]
[append-item (lambda (i iwx) [append-item (lambda (i iwx)
(set! items (append items (list i))) (set! items (append items (list i)))
(unless (is-a? i separator-menu-item%) (unless (or (is-a? i separator-menu-item%)
(not (send iwx is-enabled?)))
(let ([k (send iwx get-keymap)]) (let ([k (send iwx get-keymap)])
(when k (when k
(send keymap chain-to-keymap k #f)))))] (send keymap chain-to-keymap k #f)))))]
@ -3737,7 +3745,17 @@
(set! items (remq i items)) (set! items (remq i items))
(let ([k (send (mred->wx i) get-keymap)]) (let ([k (send (mred->wx i) get-keymap)])
(when k (when k
(send keymap remove-chained-keymap k))))]) (send keymap remove-chained-keymap k))))]
[enable (lambda (iwx id on?)
; Only called if the item is not deleted
(unless (eq? (send iwx is-enabled?) (and on? #t))
(send iwx set-enabled (and on? #t))
(super-enable id on?)
(let ([k (send iwx get-keymap)])
(when k
(if on?
(send keymap chain-to-keymap k #f)
(send keymap remove-chained-keymap k))))))])
(sequence (sequence
(super-init popup-label popup-callback)))) (super-init popup-label popup-callback))))
@ -3811,7 +3829,7 @@
[do-enable (lambda (on?) [do-enable (lambda (on?)
(when shown? (when shown?
(if in-menu? (if in-menu?
(send wx-parent enable (send wx id) on?) (send wx-parent enable wx (send wx id) on?)
(send wx-parent enable-top (send wx-parent position-of this) on?))) (send wx-parent enable-top (send wx-parent position-of this) on?)))
(set! enabled? (and on? #t)))]) (set! enabled? (and on? #t)))])
(public (public
@ -3885,6 +3903,7 @@
(class* basic-labelled-menu-item% (selectable-menu-item<%>) (label checkable? menu callback shortcut help-string set-wx) (class* basic-labelled-menu-item% (selectable-menu-item<%>) (label checkable? menu callback shortcut help-string set-wx)
(rename [super-restore restore] [super-set-label set-label] (rename [super-restore restore] [super-set-label set-label]
[super-is-deleted? is-deleted?] [super-is-deleted? is-deleted?]
[super-is-enabled? is-enabled?]
[super-get-label get-label]) [super-get-label get-label])
(private (private
[wx #f]) [wx #f])
@ -3939,7 +3958,8 @@
(let-values ([(new-label keymap) (calc-labels l)]) (let-values ([(new-label keymap) (calc-labels l)])
(set! label l) (set! label l)
(super-set-label new-label) (super-set-label new-label)
(if (super-is-deleted?) (if (or (super-is-deleted?)
(not (super-is-enabled?)))
(send wx set-keymap keymap) (send wx set-keymap keymap)
(send wx swap-keymap menu keymap)))))]) (send wx swap-keymap menu keymap)))))])
(override (override