win32: control callback fixes

collects/mred/private/wx/win32/button.rkt

@@ -74,7 +74,7 @@
     (define/override (is-command? cmd)
       (= cmd BN_CLICKED))
 
-    (define/public (do-command control-hwnd)
+    (define/public (do-command cmd control-hwnd)
       (queue-window-event this (lambda ()
                                  (callback this
                                            (new control-event%

collects/mred/private/wx/win32/canvas.rkt

@@ -418,7 +418,7 @@
      (define/override (is-command? cmd)
        (= cmd CBN_SELENDOK))
 
-     (define/public (do-command control-hwnd)
+     (define/public (do-command cmd control-hwnd)
        (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)])
          (queue-window-event this (lambda () (on-combo-select i)))))
 

collects/mred/private/wx/win32/choice.rkt

@@ -14,6 +14,10 @@
 
 (provide choice%)
 
+(define CBN_DROPDOWN        7)
+(define CBN_CLOSEUP         8)
+(define CBN_SELENDCANCEL    10)
+
 (define choice% 
   (class item%
     (init parent cb label
@@ -62,10 +66,27 @@
 
     (subclass-control hwnd)
 
+    (define choice-dropped? #f)
+
+    (define/override (ctlproc w msg wParam lParam default)
+      (cond
+       [(and choice-dropped?
+             (or (= msg WM_KEYDOWN)
+                 (= msg WM_KEYUP)
+                 (= msg WM_SYSCHAR)
+                 (= msg WM_CHAR)))
+        (default w msg wParam lParam)]
+       [else (super ctlproc w msg wParam lParam default)]))
+
     (define/override (is-command? cmd)
+      (when (= cmd CBN_DROPDOWN)
+        (set! choice-dropped? #t))
+      (when (= cmd CBN_CLOSEUP)
+        (queue-window-event this (lambda ()
+                                   (set! choice-dropped? #f))))
       (= cmd CBN_SELENDOK))
 
-    (define/public (do-command control-hwnd)
+    (define/public (do-command cmd control-hwnd)
       (queue-window-event this (lambda ()
                                  (callback this
                                            (new control-event%

collects/mred/private/wx/win32/list-box.rkt

@@ -25,6 +25,9 @@
 (define LBS_EXTENDEDSEL       #x0800)
 (define LBS_DISABLENOSCROLL   #x1000)
 
+(define LBN_SELCHANGE       1)
+(define LBN_DBLCLK          2)
+
 (define LB_ERR -1)
 
 (define LB_ADDSTRING          #x0180)
@@ -88,6 +91,22 @@
 
     (subclass-control hwnd)
 
+    (define callback cb)
+
+    (define/override (is-command? cmd)
+      (or (= cmd LBN_SELCHANGE)
+          (= cmd LBN_DBLCLK)))
+    
+    (define/public (do-command cmd control-hwnd)
+      (queue-window-event this (lambda ()
+                                 (callback this
+                                           (new control-event%
+                                                [event-type (if (= cmd LBN_SELCHANGE)
+                                                                'list-box
+                                                                'list-box-dclick)]
+                                                [time-stamp (current-milliseconds)])))))
+
+
     (define num (length choices))
     (define/public (number) num)
 

collects/mred/private/wx/win32/radio-box.rkt

@@ -105,7 +105,7 @@
     (define/override (is-command? cmd)
       (= cmd BN_CLICKED))
     
-    (define/public (do-command control-hwnd)
+    (define/public (do-command cmd control-hwnd)
       (let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)]
                                     [pos (in-naturals)])
                    (if (ptr-equal? control-hwnd radio-hwnd)

collects/mred/private/wx/win32/tab-panel.rkt

@@ -115,7 +115,7 @@
     (define/override (is-command? cmd)
       (= cmd 64985))
 
-    (define/public (do-command control-hwnd)
+    (define/public (do-command cmd control-hwnd)
       (queue-window-event this (lambda ()
                                  (callback this
                                            (new control-event%

collects/mred/private/wx/win32/window.rkt

@@ -132,33 +132,32 @@
            (default w msg wParam lParam)
            (do-key w msg wParam lParam #f #f))]
          [(= msg WM_KEYDOWN)
-          (do-key w msg wParam lParam #f #f)
+          (do-key w msg wParam lParam #f #f default)]
-          0]
          [(= msg WM_KEYUP)
-          (do-key w msg wParam lParam #f #t)
+          (do-key w msg wParam lParam #f #t default)]
-          0]
          [(and (= msg WM_SYSCHAR)
                (= wParam VK_MENU))
           (unhide-cursor)
           (begin0
            (default w msg wParam lParam)
-           (do-key w msg wParam lParam #t #f))]
+           (do-key w msg wParam lParam #t #f void))]
          [(= msg WM_CHAR)
-          (do-key w msg wParam lParam #t #f)
+          (do-key w msg wParam lParam #t #f default)]
-          0]
          [(= msg WM_COMMAND)
           (let* ([control-hwnd (cast lParam _LPARAM _HWND)]
-                 [wx (any-hwnd->wx control-hwnd)])
+                 [wx (any-hwnd->wx control-hwnd)]
-            (if (and wx (send wx is-command? (HIWORD wParam)))
+                 [cmd (HIWORD wParam)])
+            (if (and wx (send wx is-command? cmd))
                 (begin
-                  (send wx do-command control-hwnd)
+                  (send wx do-command cmd control-hwnd)
                   0)
                 (default w msg wParam lParam)))]
          [(= msg WM_NOTIFY)
           (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)]
                  [control-hwnd (NMHDR-hwndFrom nmhdr)]
-                 [wx (any-hwnd->wx control-hwnd)])
+                 [wx (any-hwnd->wx control-hwnd)]
-            (if (and wx (send wx is-command? (LOWORD (NMHDR-code nmhdr))))
+                 [cmd (LOWORD (NMHDR-code nmhdr))])
+            (if (and wx (send wx is-command? cmd))
                 (begin
                   (send wx do-command control-hwnd)
                   0)
@@ -398,17 +397,18 @@
   (define/public (get-top-frame)
     (send parent get-top-frame))
   
-  (define/private (do-key w msg wParam lParam is-char? is-up?)
+  (define/private (do-key w msg wParam lParam is-char? is-up? default)
     (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)])
-      (and e
+      (if (and e
                (if (definitely-wants-event? w msg wParam e)
                    (begin
                      (queue-window-event this (lambda () (dispatch-on-char/sync e)))
                      #t)
                    (constrained-reply (get-eventspace)
                                       (lambda () (dispatch-on-char e #t))
-                                  #t)))))
+                                      #t)))
-
+          0
+          (default w msg wParam lParam))))
 
   (define/public (try-mouse w msg wParam lParam)
     (cond