159 lines
6.7 KiB
Racket
159 lines
6.7 KiB
Racket
(module wxmenu racket/base
|
|
(require racket/class
|
|
racket/list
|
|
(prefix-in wx: "kernel.rkt")
|
|
(prefix-in wx: "wxme/keymap.rkt")
|
|
"lock.rkt"
|
|
"const.rkt"
|
|
"helper.rkt"
|
|
"wx.rkt")
|
|
|
|
(provide (protect-out wx-menu-item%
|
|
wx-menu-bar%
|
|
wx-menu%))
|
|
|
|
(define wx-menu-item%
|
|
(class* wx:menu-item% (wx<%>)
|
|
(init mr mn-dat can-enable?)
|
|
(define menu-data mn-dat)
|
|
(define mred mr)
|
|
(define keymap #f)
|
|
(define wx-menu #f)
|
|
(define enabled? #t)
|
|
(define ever-enabled? can-enable?)
|
|
(public*
|
|
[get-keymap (lambda () keymap)]
|
|
[set-keymap (lambda (k) (set! keymap k))]
|
|
[swap-keymap (lambda (parent 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-container (lambda () wx-menu)]
|
|
[set-wx-menu (lambda (wx) (set! wx-menu wx))]
|
|
[is-enabled? (lambda () enabled?)]
|
|
[set-enabled (lambda (on?) (set! enabled? on?))]
|
|
[ignore-enabled? (lambda () (not ever-enabled?))])
|
|
(super-make-object)))
|
|
|
|
(define wx-menu-bar%
|
|
(class* wx:menu-bar% (wx<%>)
|
|
(init mr)
|
|
(inherit delete)
|
|
(rename-super [super-append append]
|
|
[super-enable-top enable-top])
|
|
(define mred mr)
|
|
(define items null)
|
|
(define disabled null)
|
|
(define disabled? #f)
|
|
(define keymap (make-object wx:keymap%))
|
|
(public*
|
|
[get-container (lambda () this)]
|
|
[handle-key (lambda (event)
|
|
(as-exit
|
|
(lambda ()
|
|
(or (send keymap handle-key-event this event)
|
|
(and (menu-shortcut-in-label?)
|
|
(send event get-meta-down)
|
|
(char? (send event get-key-code))
|
|
(let ([c (send event get-key-code)])
|
|
(and (or (char-alphabetic? c)
|
|
(char-numeric? c))
|
|
(let ([re (key-regexp c)])
|
|
(ormap
|
|
(lambda (i)
|
|
(let* ([data (send (mred->wx i) get-menu-data)]
|
|
[label (mcar data)]
|
|
[menu (mcdr data)])
|
|
(if (regexp-match re label)
|
|
(send menu select this)
|
|
#f)))
|
|
items)))))))))]
|
|
[on-demand (lambda () (as-exit (lambda () (send mred on-demand))))]
|
|
[get-mred (lambda () mred)]
|
|
[get-items (lambda () items)]
|
|
[append-item (lambda (item menu title)
|
|
(super-append menu title)
|
|
(when disabled?
|
|
(super-enable-top (length items) #f))
|
|
(set! items (append items (list item)))
|
|
(send keymap chain-to-keymap (send (mred->wx item) get-keymap) #f))]
|
|
[all-enabled? (lambda () (not disabled?))]
|
|
[enable-all (lambda (on?)
|
|
(set! disabled? (not on?))
|
|
(let loop ([n (sub1 (length items))])
|
|
(unless (negative? n)
|
|
(if on?
|
|
(unless (memq (list-ref items n) disabled)
|
|
(super-enable-top n #t))
|
|
(super-enable-top n #f))
|
|
(loop (sub1 n)))))]
|
|
[delete-item (lambda (i)
|
|
(let ([p (position-of i)])
|
|
(set! items (remq i items))
|
|
(set! disabled (remq i disabled))
|
|
(delete #f p)
|
|
(send keymap remove-chained-keymap (send (mred->wx i) get-keymap))))]
|
|
[position-of (lambda (i) (find-pos items i eq?))])
|
|
(override*
|
|
[enable-top (lambda (p on?)
|
|
(let ([i (list-ref items p)])
|
|
(if on?
|
|
(when (memq i disabled)
|
|
(set! disabled (remq i disabled))
|
|
(unless disabled?
|
|
(super-enable-top p #t)))
|
|
(unless (memq i disabled)
|
|
(set! disabled (cons i disabled))
|
|
(super-enable-top p #f)))))])
|
|
(super-make-object)))
|
|
|
|
(define wx-menu%
|
|
(class* wx:menu% (wx<%>)
|
|
(init mr popup-label popup-callback font)
|
|
(define mred mr)
|
|
(define items null)
|
|
(define keymap (make-object wx:keymap%))
|
|
(define popup-grabber #f)
|
|
(inherit delete-by-position)
|
|
(rename-super [super-delete delete]
|
|
[super-enable enable])
|
|
(public*
|
|
[get-container (lambda () this)]
|
|
[get-keymap (lambda () keymap)]
|
|
[get-mred (lambda () mred)]
|
|
[get-items (lambda () items)]
|
|
[append-item (lambda (i iwx)
|
|
(set! items (append items (list i)))
|
|
(let ([k (send iwx get-keymap)])
|
|
(when k
|
|
(send keymap chain-to-keymap k #f))))]
|
|
[delete-sep (lambda (i iwx)
|
|
(delete-by-position (find-pos items i eq?))
|
|
(set! items (remq i items)))]
|
|
[swap-item-keymap (lambda (old-k new-k)
|
|
(when old-k (send keymap remove-chained-keymap old-k))
|
|
(when new-k (send keymap chain-to-keymap new-k #f)))]
|
|
|
|
[popup-grab (lambda (c)
|
|
(if popup-grabber
|
|
#f
|
|
(begin
|
|
(set! popup-grabber c)
|
|
#t)))]
|
|
[popup-release (lambda () (set! popup-grabber #f))]
|
|
[get-popup-grabber (lambda () popup-grabber)])
|
|
(override*
|
|
[delete (lambda (id i)
|
|
(super-delete id)
|
|
(set! items (remq i items))
|
|
(let ([k (send (mred->wx i) get-keymap)])
|
|
(when 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?)))])
|
|
(super-make-object popup-label popup-callback font))))
|