378 lines
13 KiB
Scheme
378 lines
13 KiB
Scheme
(module mrmenu mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "class100.ss")
|
|
(lib "list.ss")
|
|
(prefix wx: "kernel.ss")
|
|
"lock.ss"
|
|
"const.ss"
|
|
"helper.ss"
|
|
"check.ss"
|
|
"wx.ss"
|
|
"app.ss"
|
|
"wxmenu.ss"
|
|
"mrtop.ss"
|
|
"mrmenuintf.ss"
|
|
"mrpopup.ss")
|
|
|
|
(provide separator-menu-item%
|
|
menu-item%
|
|
checkable-menu-item%
|
|
menu%
|
|
menu-bar%
|
|
(protect menu-parent-only
|
|
menu-or-bar-parent))
|
|
|
|
;; Most of the work is in the item. Anything that appears in a menubar or
|
|
;; menu has an item. Submenus are created as instances of menu%, but
|
|
;; menu% has a get-item method for manipulating the menu w.r.t. the parent
|
|
;; (e.g., changing the title or enabled state). A popup menu, created
|
|
;; as an instance of popup-menu%, has no item.
|
|
;;
|
|
;; A menu bar is created as a menu-bar%, given a frame as its parent. The
|
|
;; frame must not already have a menu bar.
|
|
;;
|
|
;; Plain labeled items are created as instances of menu-item% or
|
|
;; checkable-menu-item%. The parent must be a menu-item-container<%>,
|
|
;; which is a menu%, popup-menu%, or menu-bar%
|
|
|
|
(define separator-menu-item%
|
|
(class100* mred% (menu-item<%>) (parent)
|
|
(sequence (menu-parent-only 'separator-menu-item parent))
|
|
(private-field
|
|
[prnt parent]
|
|
[wx #f]
|
|
[shown? #f]
|
|
[wx-parent #f])
|
|
(public
|
|
[get-parent (lambda () prnt)]
|
|
[restore (entry-point
|
|
(lambda ()
|
|
(unless shown?
|
|
(send wx-parent append-separator)
|
|
(send wx-parent append-item this wx)
|
|
(set! shown? #t))))]
|
|
[delete (entry-point
|
|
(lambda ()
|
|
(when shown?
|
|
(send wx-parent delete-sep this wx)
|
|
(set! shown? #f))))]
|
|
[is-deleted? (lambda () (not shown?))])
|
|
(sequence
|
|
(as-entry
|
|
(lambda ()
|
|
(set! wx (make-object wx-menu-item% this #f #f))
|
|
(set! wx-parent (send (mred->wx prnt) get-container))
|
|
(super-init wx)))
|
|
(restore))))
|
|
|
|
(define strip-tab
|
|
(if (menu-shortcut-in-label?)
|
|
(lambda (s)
|
|
(car (regexp-match #rx"^[^\t]*" s)))
|
|
(lambda (s)
|
|
(regexp-replace* #rx"&"
|
|
(regexp-replace* #rx"&(.)"
|
|
(regexp-replace*
|
|
#rx" *[(]&.[)] *"
|
|
(car (regexp-match #rx"^[^\t]*" s))
|
|
"")
|
|
"\\1")
|
|
"\\&\\&"))))
|
|
|
|
(define basic-labelled-menu-item%
|
|
(class100* mred% (labelled-menu-item<%>) (prnt lbl help-str wx-sub chkble? keymap set-wx demand-callback)
|
|
(private-field
|
|
[parent prnt]
|
|
[label lbl]
|
|
[help-string help-str]
|
|
[wx-submenu wx-sub]
|
|
[checkable? chkble?]
|
|
[callback demand-callback]
|
|
[wx #f]
|
|
[wx-parent #f]
|
|
[plain-label (string->immutable-string (wx:label->plain-label label))]
|
|
[in-menu? (is-a? parent internal-menu<%>)]
|
|
[shown? #f]
|
|
[enabled? #t])
|
|
(private
|
|
[do-enable (lambda (on?)
|
|
(when shown?
|
|
(if in-menu?
|
|
(send wx-parent enable wx (send wx id) on?)
|
|
(send wx-parent enable-top (send wx-parent position-of this) on?)))
|
|
(set! enabled? (and on? #t)))])
|
|
(public
|
|
[on-demand (lambda () (callback this))]
|
|
[get-parent (lambda () parent)]
|
|
[get-label (lambda () label)]
|
|
[set-label (entry-point
|
|
(lambda (l)
|
|
(check-label-string '(method labelled-menu-item<%> set-label) l)
|
|
(set! label (string->immutable-string l))
|
|
(set-car! (send wx get-menu-data) l) ; for meta-shortcuts
|
|
(set! plain-label (string->immutable-string (wx:label->plain-label l)))
|
|
(when shown?
|
|
(if in-menu?
|
|
(send wx-parent set-label (send wx id) l)
|
|
(send wx-parent set-label-top (send wx-parent position-of this) label)))))]
|
|
[get-plain-label (lambda () plain-label)]
|
|
[get-help-string (lambda () help-string)]
|
|
[set-help-string (entry-point
|
|
(lambda (s)
|
|
(check-label-string/false '(method labelled-menu-item<%> set-help-string) s)
|
|
(set! help-string (and s (string->immutable-string s)))
|
|
(when in-menu?
|
|
(send wx-parent set-help-string (send wx id) help-string))))]
|
|
[enable (lambda (on?) (do-enable on?))]
|
|
[is-enabled? (lambda () enabled?)]
|
|
[restore (entry-point
|
|
(lambda ()
|
|
(unless shown?
|
|
(if in-menu?
|
|
(begin
|
|
(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 wx-submenu (strip-tab label)))
|
|
(set! shown? #t)
|
|
(do-enable enabled?))))]
|
|
[delete (entry-point
|
|
(lambda ()
|
|
(when shown?
|
|
(if in-menu?
|
|
(send wx-parent delete (send wx id) this)
|
|
(send wx-parent delete-item this))
|
|
(set! shown? #f))))]
|
|
[is-deleted? (lambda () (not shown?))])
|
|
(sequence
|
|
(as-entry
|
|
(lambda ()
|
|
(when help-string
|
|
(set! help-string (string->immutable-string help-string)))
|
|
(set! wx (set-wx (make-object wx-menu-item% this (cons label #f) #t)))
|
|
(set! wx-parent (send (mred->wx parent) get-container))
|
|
(super-init wx)
|
|
(when keymap (send wx set-keymap keymap))))
|
|
(restore))))
|
|
|
|
(define (char-name c print?)
|
|
(case c
|
|
[(#\return) (if (eq? (system-type) 'macos) "Return" "Enter")]
|
|
[(#\tab) "Tab"]
|
|
[(#\space) "Space"]
|
|
[(#\backspace) "Backspace"]
|
|
[(#\rubout) "Delete"]
|
|
[(#\:) (if print? ":" "Colon")]
|
|
[(#\;) (if print? ";" "Semicolon")]
|
|
[else c]))
|
|
|
|
(define basic-selectable-menu-item%
|
|
(class100* basic-labelled-menu-item% (selectable-menu-item<%>) (lbl checkable? mnu cb shrtcut help-string set-wx demand-callback)
|
|
(inherit is-enabled?)
|
|
(rename [super-restore restore] [super-set-label set-label]
|
|
[super-is-deleted? is-deleted?]
|
|
[super-is-enabled? is-enabled?]
|
|
[super-get-label get-label])
|
|
(private-field
|
|
[menu mnu]
|
|
[callback cb]
|
|
[label lbl]
|
|
[shortcut shrtcut]
|
|
[wx #f])
|
|
(public
|
|
[command (lambda (e)
|
|
(check-instance '(method selectable-menu-item<%> command) wx:control-event% 'control-event% #f e)
|
|
(void (callback this e)))])
|
|
(private-field
|
|
[x-prefix default-x-prefix])
|
|
(private
|
|
[calc-labels (lambda (label)
|
|
(let* ([new-label (if shortcut
|
|
(string-append
|
|
(strip-tab label)
|
|
(case (system-type)
|
|
[(unix) (format "~a~a~a" #\tab
|
|
(case x-prefix
|
|
[(meta) "Meta+"]
|
|
[(alt) "Alt+"]
|
|
[(ctl-m) "Ctl+M "]
|
|
[(ctl) "Ctl+"])
|
|
(char-name
|
|
(char-upcase shortcut)
|
|
#t))]
|
|
[(windows) (format "~aCtl+~a" #\tab
|
|
(char-name (char-upcase shortcut) #t))]
|
|
[(macos macosx) (format "~aCmd+~a" #\tab
|
|
(char-name (char-upcase shortcut) #t))]))
|
|
(strip-tab label))]
|
|
[key-binding (and shortcut
|
|
(case (system-type)
|
|
[(unix) (format "~a~a"
|
|
(case x-prefix
|
|
[(meta) ":m:"]
|
|
[(alt) ":m:"]
|
|
[(ctl-m) ":c:m;:"]
|
|
[(ctl) ":c:"])
|
|
(char-name (char-downcase shortcut) #f))]
|
|
[(windows) (format ":c:~a" (char-name (char-downcase shortcut) #f))]
|
|
[(macos macosx) (format ":d:~a" (char-name (char-downcase shortcut) #f))]))]
|
|
[keymap (and key-binding
|
|
(let ([keymap (make-object wx:keymap%)])
|
|
(send keymap add-function "menu-item"
|
|
;; keymap function callback already in exit mode:
|
|
(lambda (edit event)
|
|
(when (is-enabled?)
|
|
(callback this (make-object wx:control-event% 'menu)))))
|
|
(send keymap map-function key-binding "menu-item")
|
|
keymap))])
|
|
(values new-label keymap)))])
|
|
(private
|
|
[do-set-label (entry-point
|
|
(lambda (l)
|
|
(check-label-string '(method labelled-menu-item<%> set-label) l)
|
|
(let-values ([(new-label keymap) (calc-labels l)])
|
|
(set! label (string->immutable-string l))
|
|
(super-set-label new-label)
|
|
(if (or (super-is-deleted?)
|
|
(not (super-is-enabled?)))
|
|
(send wx set-keymap keymap)
|
|
(send wx swap-keymap menu keymap)))))])
|
|
(override
|
|
[get-label (lambda () label)]
|
|
[set-label (lambda (s) (do-set-label s))])
|
|
(public
|
|
[set-shortcut (lambda (c)
|
|
(check-char/false '(method selectable-menu-item<%> set-shortcut) c)
|
|
(unless (equal? shortcut c)
|
|
(set! shortcut c)
|
|
(do-set-label 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 selectable-menu-item<%> set-x-shortcut-prefix))
|
|
"symbol: meta, alt, ctl-m, or ctl" p))
|
|
(set! x-prefix p) (do-set-label label))])
|
|
(sequence
|
|
(set! label (string->immutable-string label))
|
|
(let-values ([(new-label keymap) (calc-labels label)])
|
|
(super-init menu new-label help-string #f checkable? keymap (lambda (x) (set! wx x) (set-wx x)) demand-callback)))))
|
|
|
|
(define (check-shortcut-args who label menu callback shortcut help-string demand-callback)
|
|
(let ([cwho `(constructor ,who)])
|
|
(check-label-string cwho label)
|
|
(menu-parent-only who menu)
|
|
(check-callback cwho callback)
|
|
(check-char/false cwho shortcut)
|
|
(check-label-string/false cwho help-string)
|
|
(check-callback1 cwho demand-callback)))
|
|
|
|
(define menu-item%
|
|
(class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void])
|
|
(sequence
|
|
(check-shortcut-args 'menu-item label parent callback shortcut help-string demand-callback)
|
|
(super-init label #f parent callback shortcut help-string (lambda (x) x) demand-callback))))
|
|
|
|
(define checkable-menu-item%
|
|
(class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void] [checked #f])
|
|
(sequence
|
|
(check-shortcut-args 'checkable-menu-item label parent callback shortcut help-string demand-callback))
|
|
(private-field
|
|
[mnu parent]
|
|
[wx #f])
|
|
(public
|
|
[check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))]
|
|
[is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))])
|
|
(sequence
|
|
(super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback)
|
|
(when checked (check #t)))))
|
|
|
|
(define menu%
|
|
(class100* basic-labelled-menu-item% (menu-item-container<%> internal-menu<%>) (label parent [help-string #f] [demand-callback void])
|
|
(private-field
|
|
[callback demand-callback])
|
|
(sequence
|
|
(check-label-string '(constructor menu) label)
|
|
(menu-or-bar-parent 'menu parent)
|
|
(check-label-string/false '(constructor menu) help-string)
|
|
(check-callback1 '(constructor menu) demand-callback))
|
|
(public
|
|
[get-items (entry-point (lambda () (send wx-menu get-items)))])
|
|
(override
|
|
[on-demand (lambda ()
|
|
(callback this)
|
|
(for-each
|
|
(lambda (i)
|
|
(when (is-a? i labelled-menu-item<%>)
|
|
(send i on-demand)))
|
|
(send wx-menu get-items)))])
|
|
(private-field
|
|
[wx-menu #f])
|
|
(sequence
|
|
(as-entry
|
|
(lambda ()
|
|
(set! wx-menu (make-object wx-menu% this #f void #f))
|
|
(super-init parent label help-string wx-menu #f (send wx-menu get-keymap) (lambda (x) x) void)
|
|
(let ([wx-item (mred->wx this)])
|
|
(set-cdr! (send wx-item get-menu-data) wx-menu) ; for meta-shortcuts
|
|
(send wx-item set-wx-menu wx-menu)))))))
|
|
|
|
(define menu-bar%
|
|
(class100* mred% (menu-item-container<%>) (parent [demand-callback void])
|
|
(sequence
|
|
(unless (or (is-a? parent frame%) (eq? parent 'root))
|
|
(raise-type-error (constructor-name 'menu-bar) "frame% object or 'root" parent))
|
|
(check-callback1 '(constructor menu-bar) demand-callback)
|
|
(if (eq? parent 'root)
|
|
(unless (current-eventspace-has-menu-root?)
|
|
(raise-mismatch-error (constructor-name 'menu-bar) "no menu bar allowed in the current eventspace for: " parent))
|
|
(when (as-entry (lambda () (send (mred->wx parent) get-the-menu-bar)))
|
|
(raise-mismatch-error (constructor-name 'menu-bar) "the specified frame already has a menu bar: " parent))))
|
|
(private-field
|
|
[callback demand-callback]
|
|
[prnt (if (eq? parent 'root)
|
|
(let ([f (make-object (class frame%
|
|
(define/override (on-exit)
|
|
(exit))
|
|
(super-make-object "Root")))])
|
|
(as-entry
|
|
(lambda ()
|
|
(when root-menu-frame
|
|
(raise-mismatch-error (constructor-name 'menu-bar) "already has a menu bar: " parent))
|
|
(send (mred->wx f) designate-root-frame)
|
|
(set-root-menu-frame! f)))
|
|
f)
|
|
parent)]
|
|
[wx #f]
|
|
[wx-parent #f]
|
|
[shown? #f])
|
|
(public
|
|
[get-frame (lambda () prnt)]
|
|
[get-items (entry-point (lambda () (send wx get-items)))]
|
|
[enable (entry-point (lambda (on?) (send wx enable-all on?)))]
|
|
[is-enabled? (entry-point (lambda () (send wx all-enabled?)))]
|
|
[on-demand (lambda ()
|
|
(callback this)
|
|
(for-each
|
|
(lambda (i) (send i on-demand))
|
|
(send wx get-items)))])
|
|
(sequence
|
|
(as-entry
|
|
(lambda ()
|
|
(set! wx (make-object wx-menu-bar% this))
|
|
(set! wx-parent (mred->wx prnt))
|
|
(super-init wx)
|
|
(send wx-parent set-menu-bar wx)
|
|
(send wx-parent self-redraw-request))))))
|
|
|
|
(define (menu-parent-only who p)
|
|
(unless (is-a? p internal-menu<%>)
|
|
(raise-type-error (constructor-name who) "parent menu% or popup-menu% object" p)))
|
|
|
|
(define (menu-or-bar-parent who p)
|
|
(unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
|
|
(raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p)))
|
|
|
|
(wx:set-menu-tester (lambda (m) (is-a? m popup-menu%))))
|