From 6e628325ca82a5a6bee8810173faeabad554445c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 2 Feb 1999 23:59:13 +0000 Subject: [PATCH] . original commit: ff5d666c9d395f8be9d13fe97fc3c5434ee9c223 --- src/mred/wrap/mred.ss | 77 +++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 39 deletions(-) diff --git a/src/mred/wrap/mred.ss b/src/mred/wrap/mred.ss index f2168a82..8ee1f20b 100644 --- a/src/mred/wrap/mred.ss +++ b/src/mred/wrap/mred.ss @@ -3504,15 +3504,18 @@ (define wx-menu-item% (class* wx:menu-item% (wx<%>) (mred menu-data) (private - [keymap #f]) + [keymap #f] + [wx-menu #f]) (public [get-keymap (lambda () keymap)] [set-keymap (lambda (k) (set! keymap k))] [swap-keymap (lambda (parent k) - (send (mred->wx parent) swap-item-keymap keymap k) + (send (send (mred->wx parent) get-container) swap-item-keymap keymap k) (set-keymap k))] [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)] + [set-wx-menu (lambda (wx) (set! wx-menu wx))]) (sequence (super-init)))) @@ -3527,6 +3530,7 @@ [disabled? #f] [keymap (make-object wx:keymap%)]) (public + [get-container (lambda () this)] [handle-key (lambda (event) (as-exit (lambda () @@ -3673,19 +3677,19 @@ (as-entry (lambda () (set! wx (make-object wx-menu-item% this #f)) - (set! wx-parent (mred->wx parent)) + (set! wx-parent (send (mred->wx parent) get-container)) (super-init wx))) (restore)))) (define (strip-tab s) (car (regexp-match (format "^[^~a]*" #\tab) s))) (define basic-labelled-menu-item% - (class* mred% (labelled-menu-item<%>) (parent label help-string submenu checkable? keymap set-wx) + (class* mred% (labelled-menu-item<%>) (parent label help-string wx-submenu checkable? keymap set-wx) (private [wx #f] [wx-parent #f] [plain-label (wx:label->plain-label label)] - [in-menu? (is-a? parent basic-menu%)] + [in-menu? (is-a? parent internal-menu<%>)] [shown? #f] [enabled? #t] [do-enable (lambda (on?) @@ -3722,11 +3726,11 @@ (unless shown? (if in-menu? (begin - (if submenu - (send wx-parent append (send wx id) label (mred->wx submenu) help-string) + (if wx-submenu + (send wx-parent append (send wx id) label wx-submenu help-string) (send wx-parent append (send wx id) label help-string checkable?)) (send wx-parent append-item this wx)) - (send wx-parent append-item this (mred->wx submenu) label)) + (send wx-parent append-item this wx-submenu label)) (set! shown? #t) (do-enable enabled?))))] [delete (entry-point @@ -3734,26 +3738,26 @@ (when shown? (if in-menu? (send wx-parent delete (send wx id) this) - (send (mred->wx parent) delete-item this)) + (send wx-parent delete-item this)) (set! shown? #f))))] [is-deleted? (lambda () (not shown?))]) (sequence (as-entry (lambda () (set! wx (set-wx (make-object wx-menu-item% this (cons label #f)))) - (set! wx-parent (mred->wx parent)) + (set! wx-parent (send (mred->wx parent) get-container)) (super-init wx) (when keymap (send wx set-keymap keymap)))) (restore)))) -(define shortcut-menu-item<%> +(define selectable-menu-item<%> (interface (labelled-menu-item<%>) command get-shortcut set-shortcut get-x-shortcut-prefix set-x-shortcut-prefix)) -(define basic-shortcut-menu-item% - (class* basic-labelled-menu-item% (shortcut-menu-item<%>) (label checkable? menu callback shortcut help-string set-wx) +(define basic-selectable-menu-item% + (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] [super-is-deleted? is-deleted?] [super-get-label get-label]) @@ -3761,7 +3765,7 @@ [wx #f]) (public [command (lambda (e) - (check-instance '(method shortcut-menu-item<%> command) wx:control-event% 'control-event% #f e) + (check-instance '(method selectable-menu-item<%> command) wx:control-event% 'control-event% #f e) (void (callback this e)))]) (private [x-prefix 'meta] @@ -3815,13 +3819,13 @@ [set-label do-set-label]) (public [set-shortcut (lambda (c) - (check-char/false '(method shortcut-menu-item<%> set-shortcut) c) + (check-char/false '(method selectable-menu-item<%> set-shortcut) c) (set! shortcut c) (do-set-label (super-get-label)))] [get-shortcut (lambda () shortcut)] [get-x-shortcut-prefix (lambda () x-prefix)] [set-x-shortcut-prefix (lambda (p) (unless (memq p '(meta alt ctl-m ctl)) - (raise-type-error (who->name '(method shortcut-menu-item<%> set-x-shortcut-prefix)) + (raise-type-error (who->name '(method selectable-menu-item<%> set-x-shortcut-prefix)) "symbol: meta, alt, ctl-m, or ctl" p)) (set! x-prefix p) (do-set-label (super-get-label)))]) (sequence @@ -3837,31 +3841,23 @@ (check-string/false cwho help-string))) (define menu-item% - (class basic-shortcut-menu-item% (label menu callback [shortcut #f] [help-string #f]) + (class basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f]) (sequence (check-shortcut-args 'menu-item label menu callback shortcut help-string) (super-init label #f menu callback shortcut help-string (lambda (x) x))))) (define checkable-menu-item% - (class basic-shortcut-menu-item% (label menu callback [shortcut #f] [help-string #f]) + (class basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f]) (sequence (check-shortcut-args 'checkable-menu-item label menu callback shortcut help-string)) (private [wx #f]) (public - [check (entry-point-1 (lambda (on?) (send (mred->wx menu) check (send wx id) on?)))] - [is-checked? (entry-point (lambda () (send (mred->wx menu) checked? (send wx id))))]) + [check (entry-point-1 (lambda (on?) (send (send (mred->wx menu) get-container) check (send wx id) on?)))] + [is-checked? (entry-point (lambda () (send (send (mred->wx menu) get-container) checked? (send wx id))))]) (sequence (super-init label #t menu callback shortcut help-string (lambda (x) (set! wx x) x))))) -(define sub-menu-item% - ; >> Not for export << - (class* basic-labelled-menu-item% (submenu-item<%>) (menu label parent help-string) - (public - [get-menu (lambda () menu)]) - (sequence - (super-init parent label help-string menu #f (send (mred->wx menu) get-keymap) (lambda (x) x))))) - (define menu-item-container<%> (interface () get-items)) (define internal-menu<%> (interface ())) @@ -3876,20 +3872,23 @@ (super-init wx)))) (define menu% - (class basic-menu% (label parent [help-string #f]) - (private - [item #f]) - (public - [get-item (lambda () item)]) + (class* basic-labelled-menu-item% (menu-item-container<%> internal-menu<%>) (label parent [help-string #f]) (sequence (check-string '(constructor menu) label) (menu-or-bar-parent 'menu parent) - (check-string/false '(constructor menu) help-string) + (check-string/false '(constructor menu) help-string)) + (public + [get-items (entry-point (lambda () (send wx-menu get-items)))]) + (private + [wx-menu #f]) + (sequence (as-entry (lambda () - (super-init #f void) - (set! item (make-object sub-menu-item% this label parent help-string)) - (set-cdr! (send (mred->wx item) get-menu-data) (mred->wx this))))))) ; for meta-shortcuts + (set! wx-menu (make-object wx-menu% this #f void)) + (super-init parent label help-string wx-menu #f (send wx-menu get-keymap) (lambda (x) x)) + (let ([wx-item (mred->wx this)]) + (set-cdr! (send wx-item get-menu-data) wx-item) ; for meta-shortcuts + (send wx-item set-wx-menu wx-menu))))))) (define popup-menu% (class basic-menu% ([title #f]) @@ -4609,7 +4608,7 @@ (let ([p (send i get-parent)]) (cond [(not p) #f] - [(is-a? p menu%) (loop (send p get-item))] + [(is-a? p menu%) (loop p)] [else (send p get-frame)])))) (define append-editor-operation-menu-items