66 lines
1.7 KiB
Racket
66 lines
1.7 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
(only-in racket/list take drop)
|
|
ffi/unsafe
|
|
"../../lock.rkt"
|
|
"../../syntax.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt")
|
|
|
|
(provide
|
|
(protect-out menu-bar%))
|
|
|
|
(define-user32 CreateMenu (_wfun -> _HMENU))
|
|
(define-user32 SetMenu (_wfun _HWND _HMENU -> (r : _BOOL)
|
|
-> (unless r (failed 'SetMenu))))
|
|
(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL)
|
|
-> (unless r (failed 'DrawMenuBar))))
|
|
|
|
(define menu-bar%
|
|
(class object%
|
|
(super-new)
|
|
|
|
(define hmenu (CreateMenu))
|
|
|
|
(define menus null)
|
|
(define parent #f)
|
|
|
|
(define/public (set-label-top pos str)
|
|
(send (list-ref menus pos) set-menu-label hmenu pos str)
|
|
(refresh))
|
|
|
|
(define/public (number) (length menus))
|
|
|
|
(define/public (enable-top pos on?)
|
|
(send (list-ref menus pos) enable-self hmenu pos on?)
|
|
(refresh))
|
|
|
|
(define/public (delete which pos)
|
|
(atomically
|
|
(set! menus (append (take menus pos)
|
|
(drop menus (add1 pos))))
|
|
(RemoveMenu hmenu pos MF_BYPOSITION)
|
|
(refresh)))
|
|
|
|
(define/private (refresh)
|
|
(when parent
|
|
(send parent draw-menu-bar)))
|
|
|
|
(public [append-item append])
|
|
(define (append-item m lbl)
|
|
(let ([l (append menus (list m))])
|
|
(atomically
|
|
(set! menus l)
|
|
(send m set-parent this lbl hmenu)))
|
|
(refresh))
|
|
|
|
(define/public (popup-menu-with-char c)
|
|
(when parent
|
|
(send parent popup-menu-with-char c)))
|
|
|
|
(define/public (set-parent f)
|
|
(SetMenu (send f get-hwnd) hmenu)
|
|
(set! parent f)
|
|
(send parent draw-menu-bar))))
|