1#lang racket/base 2(require ffi/unsafe 3 racket/class 4 "utils.rkt" 5 "types.rkt" 6 "const.rkt" 7 "../../lock.rkt" 8 "../../syntax.rkt") 9 10(provide 11 (protect-out menu-item% 12 id-to-menu-item)) 13 14;; Menu itens are identified by 16-bit numbers, so we have 15;; to keep a hash mapping them to menu items. 16(define ids (make-hash)) 17 18(define (id-to-menu-item id) 19 (let ([wb (atomically (hash-ref ids id #f))]) 20 (and wb (weak-box-value wb)))) 21 22(defclass menu-item% object% 23 24 (define id 25 (let loop () 26 (let ([id (add1 (random #x7FFE))]) 27 (let ([wb (atomically (hash-ref ids id #f))]) 28 (if (and wb 29 (weak-box-value wb)) 30 (loop) 31 (begin 32 (atomically (hash-set! ids id (make-weak-box this))) 33 id)))))) 34 35 (define parent #f) 36 (define label #f) 37 (define checkable? #f) 38 (define submenu #f) 39 40 (define/public (set-parent p lbl chkbl? subm) 41 (set! parent p) 42 (set! label lbl) 43 (set! checkable? chkbl?) 44 (set! submenu subm) 45 id) 46 47 (define/public (set-label hmenu pos str) 48 (if submenu 49 (ModifyMenuW hmenu pos 50 (bitwise-ior MF_BYPOSITION MF_STRING MF_POPUP) 51 (cast (send submenu get-hmenu) _HMENU _UINT_PTR) 52 str) 53 (ModifyMenuW hmenu pos 54 (bitwise-ior MF_BYPOSITION MF_STRING 55 (GetMenuState hmenu pos MF_BYPOSITION)) 56 id 57 str))) 58 59 (define/public (set-check hmenu pos on?) 60 (void 61 (CheckMenuItem hmenu pos (bitwise-ior MF_BYPOSITION 62 (if on? 63 MF_CHECKED 64 MF_UNCHECKED))))) 65 66 (define/public (get-check hmenu pos) 67 (let ([s (GetMenuState hmenu pos MF_BYPOSITION)]) 68 (not (zero? (bitwise-and s MF_CHECKED))))) 69 70 (define/public (auto-check) 71 (when checkable? 72 (send parent auto-check id))) 73 74 (public [get-id id]) 75 (define (get-id) id) 76 77 (super-new)) 78