win32 menu and button callbacks

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

@@ -1,6 +1,7 @@
 #lang scheme/base
 (require scheme/class
           "../../syntax.rkt"
+          "../common/event.rkt"
          "item.rkt"
 	 "utils.rkt"
 	 "const.rkt"
@@ -14,6 +15,8 @@
 
   (init parent cb label x y w h style font)
 
+  (define callback cb)
+
   (super-new [parent parent]
 	     [hwnd 
 	      (CreateWindowExW 0
@@ -29,4 +32,11 @@
 
   (auto-size label 40 12 12 0)
 
+  (define/public (do-command)
+    (queue-window-event this (lambda ()
+                               (callback this
+                                         (new control-event%
+                                              [event-type 'button]
+                                              [time-stamp (current-milliseconds)])))))
+
   (def/public-unimplemented set-border))

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

@@ -566,3 +566,26 @@
 (define GW_HWNDPREV         3)
 (define GW_OWNER            4)
 (define GW_CHILD            5)
+
+(define MF_INSERT           #x00000000)
+(define MF_CHANGE           #x00000080)
+(define MF_APPEND           #x00000100)
+(define MF_DELETE           #x00000200)
+(define MF_REMOVE           #x00001000)
+(define MF_BYCOMMAND        #x00000000)
+(define MF_BYPOSITION       #x00000400)
+(define MF_SEPARATOR        #x00000800)
+(define MF_ENABLED          #x00000000)
+(define MF_GRAYED           #x00000001)
+(define MF_DISABLED         #x00000002)
+(define MF_UNCHECKED        #x00000000)
+(define MF_CHECKED          #x00000008)
+(define MF_USECHECKBITMAPS  #x00000200)
+(define MF_STRING           #x00000000)
+(define MF_BITMAP           #x00000004)
+(define MF_OWNERDRAW        #x00000100)
+(define MF_POPUP            #x00000010)
+(define MF_MENUBARBREAK     #x00000020)
+(define MF_MENUBREAK        #x00000040)
+(define MF_UNHILITE         #x00000000)
+(define MF_HILITE           #x00000080)

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

@@ -3,6 +3,7 @@
          (only-in racket/list last)
          ffi/unsafe
 	 "../../syntax.rkt"
+	 "../../lock.rkt"
 	 "../common/queue.rkt"
          "utils.ss"
          "const.ss"
@@ -88,6 +89,10 @@
             (when on? (set-frame-focus))
             (queue-window-event this (lambda () (on-activate on?))))))
       0]
+     [(and (= msg WM_COMMAND)
+           (zero? (HIWORD wParam)))
+      (queue-window-event this (lambda () (on-menu-command (LOWORD wParam))))
+      0]
      [else (super wndproc w msg wParam lParam)]))
 
   (define/public (on-close) (void))
@@ -104,7 +109,9 @@
 
   (def/public-unimplemented on-toolbar-click)
   (def/public-unimplemented on-menu-click)
-  (def/public-unimplemented on-menu-command)
+
+  (define/public (on-menu-command i) (void))
+
   (def/public-unimplemented on-mdi-activate)
 
   (define/public (enforce-size min-x min-y max-x max-y step-x step-y)
@@ -153,7 +160,11 @@
   (def/public-unimplemented iconized?)
   (def/public-unimplemented get-menu-bar)
 
-  (define/public (set-menu-bar mb) (void))
+  (define menu-bar #f)
+  (define/public (set-menu-bar mb)
+    (atomically
+     (set! menu-bar mb)
+     (send mb set-parent this)))
 
   (def/public-unimplemented set-icon)
   (def/public-unimplemented iconize)

collects/mred/private/wx/win32/menu-bar.rkt

@@ -1,13 +1,40 @@
 #lang scheme/base
 (require scheme/class
-          "../../syntax.rkt")
+         ffi/unsafe
+         "../../lock.rkt"
+         "../../syntax.rkt"
+         "utils.rkt"
+         "types.rkt"
+         "const.rkt")
 
 (provide menu-bar%)
 
-(defclass menu-bar% object%
+(define-user32 CreateMenu (_wfun -> _HMENU))
-  (def/public-unimplemented set-label-top)
+(define-user32 SetMenu (_wfun _HWND _HMENU -> (r : _BOOL)
-  (def/public-unimplemented number)
+                              -> (unless r (failed 'SetMenu))))
-  (def/public-unimplemented enable-top)
+(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL)
-  (def/public-unimplemented delete)
+                                  -> (unless r (failed 'DrawMenuBar))))
-  (define/public (append m l) (void))
+
-  (super-new))
+(define menu-bar% 
+  (class object%
+    (super-new)
+
+    (define hmenu (CreateMenu))
+
+    (define menus null)
+
+    (def/public-unimplemented set-label-top)
+    (def/public-unimplemented number)
+    (def/public-unimplemented enable-top)
+    (def/public-unimplemented delete)
+
+    (public [append-item append])
+    (define (append-item m lbl)
+      (let ([l (append menus (list m))])
+        (atomically
+         (set! menus l)
+         (send m set-parent this lbl hmenu))))
+
+    (define/public (set-parent f)
+      (SetMenu (send f get-hwnd) hmenu)
+      (DrawMenuBar (send f get-hwnd)))))

collects/mred/private/wx/win32/menu-item.rkt

@@ -1,9 +1,43 @@
 #lang scheme/base
-(require scheme/class
+(require ffi/unsafe
+         scheme/class
           "../../syntax.rkt")
 
-(provide menu-item%)
+(provide menu-item%
+         id-to-menu-item)
+
+;; Menu itens are identified by 16-bit numbers, so we have
+;;  to keep a hash mapping them to menu items.
+(define ids (make-hash))
+
+(define (id-to-menu-item id)
+  (let ([wb (hash-ref ids id #f)])
+    (and wb (weak-box-value wb))))
 
 (defclass menu-item% object%
-  (define/public (id) this)
+
+  (define id
+    (let loop ()
+      (let ([id (add1 (random #x7FFE))])
+        (let ([wb (hash-ref ids id #f)])
+          (if (and wb
+                   (weak-box-value wb))
+              (loop)
+              (begin
+                (hash-set! ids id (make-weak-box this))
+                id))))))
+
+  (define parent #f)
+  (define label #f)
+  (define checkable? #f)
+
+  (define/public (set-parent p lbl chkbl?)
+    (set! parent p)
+    (set! label lbl)
+    (set! checkable? chkbl?)
+    id)
+
+  (public [get-id id])
+  (define (get-id) id)
+
   (super-new))

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

@@ -1,14 +1,38 @@
 #lang scheme/base
 (require scheme/class
-          "../../syntax.rkt")
+         ffi/unsafe
+         "../../lock.rkt"
+         "../../syntax.rkt"
+         "utils.rkt"
+         "types.rkt"
+         "const.rkt"
+         "menu-item.rkt")
 
 (provide menu%)
 
+(define-user32 CreatePopupMenu (_wfun -> _HMENU))
+(define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL)
+                                  -> (unless r (failed 'AppendMenuW))))
+
 (defclass menu% object%
-  (init label
+  (init lbl
         callback
         font)
 
+  (define label lbl)
+  (define parent #f)
+  (define items null)
+
+  (define hmenu (CreatePopupMenu))
+
+  (define/public (set-parent p lbl parent-hmenu)
+    (set! label lbl)
+    (set! parent p)
+    (AppendMenuW parent-hmenu 
+                 (bitwise-ior MF_POPUP MF_STRING)
+                 hmenu
+                 lbl))
+
   (def/public-unimplemented select)
   (def/public-unimplemented get-font)
   (def/public-unimplemented set-width)
@@ -24,9 +48,14 @@
 
   (public [append-item append])
   (define (append-item i label help-str-or-submenu chckable?)
-    (void))
+    (let ([id (send (id-to-menu-item i) set-parent this label chckable?)])
+      (atomically
+       (set! items (append items (list i)))
+       (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label))))
 
   (define/public (append-separator) 
-    (void))
+    (atomically
+     (set! items (append items (list #f)))
+     (AppendMenuW hmenu MF_SEPARATOR #f #f)))
 
   (super-new))

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

@@ -6,6 +6,7 @@
          "types.rkt"
          "utils.rkt"
          "const.rkt"
+         "menu-item.rkt"
 	 racket/draw)
 
 (provide
@@ -84,7 +85,6 @@
 (define-unimplemented get-display-depth)
 (define-unimplemented is-color-display?)
 (define-unimplemented file-selector)
-(define-unimplemented id-to-menu-item)
 (define-unimplemented get-the-x-selection)
 (define-unimplemented get-the-clipboard)
 (define-unimplemented show-print-setup)

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

@@ -10,7 +10,9 @@
 	 define-comctl32
 	 define-uxtheme
          define-mz
-         failed)
+         failed
+
+         SendMessageW)
 
 (define gdi32-lib (ffi-lib "gdi32.dll"))
 (define user32-lib (ffi-lib "user32.dll"))
@@ -30,3 +32,5 @@
   (error who "call failed (~s)"
          (GetLastError)))
 
+(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
+

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

@@ -36,8 +36,6 @@
 
 (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
 
-(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
-
 (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL)
                                 -> (unless r (failed 'MoveWindow))))
 
@@ -46,6 +44,11 @@
 (define SW_SHOW 5)
 (define SW_HIDE 0)
 
+(define-cstruct _NMHDR
+  ([hwndFrom _HWND]
+   [idFrom _pointer]
+   [code _UINT]))
+
 (define-user32 GetDialogBaseUnits (_fun -> _LONG))
 (define measure-dc #f)
 
@@ -99,6 +102,20 @@
      [(= msg WM_CHAR)
       (do-key wParam lParam #t #f)
       0]
+     [(= msg WM_COMMAND)
+      (let* ([control-hwnd (cast lParam _LPARAM _HWND)]
+             [wx (any-hwnd->wx control-hwnd)])
+        (if wx 
+            (begin
+              (send wx do-command)
+              0)
+            (DefWindowProcW 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)])
+        (when wx (send wx do-command)))
+      0]
      [else
       (DefWindowProcW w msg wParam lParam)]))
 

collects/mred/private/wxtop.rkt

@@ -680,17 +680,11 @@
 	    (when mb (set! menu-bar mb))
 	    (super set-menu-bar mb))]
 	 [on-menu-command
-	  (entry-point
+          (entry-point
-	   (lambda (id)
+           (lambda (id)
-	     (let ([wx (wx:id-to-menu-item id)])
+             (let ([wx (wx:id-to-menu-item id)])
-	       (let ([go (lambda ()
+               (when wx
-			   (do-command (wx->mred wx) (make-object wx:control-event% 'menu)))])
+                 (do-command (wx->mred wx) (make-object wx:control-event% 'menu))))))]
-		 (if (eq? 'windows (system-type))
-		     ;; Windows: need trampoline
-		     (wx:queue-callback 
-		      (entry-point (lambda () (go)))
-		      wx:middle-queue-key)
-		     (go))))))]
 	 [on-menu-click
 	  (entry-point
 	   (lambda ()