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