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