1#lang racket/base
2
3(require racket/class
4         racket/list
5         (prefix-in wx: "kernel.rkt")
6         (prefix-in wx: (only-in "wxme/cycle.rkt" set-popup-menu%!))
7         "lock.rkt"
8         "const.rkt"
9         "helper.rkt"
10         "check.rkt"
11         "wx.rkt"
12         "wxmenu.rkt"
13         "mrmenuintf.rkt")
14
15(provide popup-menu%)
16
17(define popup-menu%
18  (class* mred% (menu-item-container<%> internal-menu<%>)
19    (init [title #f][popdown-callback void][demand-callback void][font no-val])
20    (define callback demand-callback)
21    (public*
22     [get-popup-target
23      (lambda ()
24        (send wx get-popup-grabber))]
25     [get-items (entry-point (lambda () (send wx get-items)))]
26     [on-demand (lambda ()
27                  (callback this)
28                  (for-each
29                   (lambda (i)
30                     (when (is-a? i labelled-menu-item<%>)
31                       (send i on-demand)))
32                   (send wx get-items)))]
33     [set-min-width (lambda (n)
34                      (check-dimension '(method popup-menu% set-min-width) n)
35                      (send wx set-width n))]
36     [get-font (lambda ()
37                 (send wx get-font))])
38    (define wx #f)
39    (let ([cwho '(constructor popup-menu)])
40      (check-label-string/false cwho title)
41      (check-callback cwho popdown-callback)
42      (check-callback1 cwho demand-callback)
43      (check-font cwho font))
44    (as-entry
45     (lambda ()
46       (set! wx (make-object wx-menu% this title
47                             (lambda (mwx e)
48                               (let ([go
49                                      (lambda ()
50                                        (let ([wx (wx:id-to-menu-item (send e get-menu-id))])
51                                          (when wx
52                                            (send (wx->mred wx) command (make-object wx:control-event% 'menu)))
53                                          (dynamic-wind
54                                            void
55                                            (lambda ()
56                                              (popdown-callback this (make-object wx:control-event%
57                                                                                  (if wx
58                                                                                      'menu-popdown
59                                                                                      'menu-popdown-none))))
60                                            (lambda () (send mwx popup-release)))))])
61                                 (if (eq? 'windows (system-type))
62                                     (wx:queue-callback go wx:middle-queue-key)
63                                     (go))))
64                             (no-val->#f font)))
65       (super-make-object wx)))))
66
67(wx:set-popup-menu%! popup-menu%)
68