win32: more menus and widgets

original commit: 70b26a58855d66ee521171005189bc23f8b1e0fd

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

@@ -254,4 +254,7 @@
      (def/public-unimplemented scroll)
      (def/public-unimplemented warp-pointer)
      (def/public-unimplemented view-start)
-     (def/public-unimplemented set-resize-corner))))
+
+     (define/public (set-resize-corner on?)
+       (void)))))
+

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

@@ -3,6 +3,7 @@
          racket/draw
          ffi/unsafe
           "../../syntax.rkt"
+          "../../lock.rkt"
           "../common/event.rkt"
          "item.rkt"
 	 "utils.rkt"
@@ -18,6 +19,8 @@
 (define CB_SETCURSEL #x014E)
 (define CB_GETCURSEL #x0147)
 (define CBN_SELENDOK 9)
+(define CB_ADDSTRING #x0143)
+(define CB_RESETCONTENT #x014B)
 
 (define choice% 
   (class item%
@@ -59,7 +62,8 @@
     (set-control-font font)
     ;; setting the choice height somehow sets the 
     ;; popup-menu size, not the control that you see
-    (auto-size choices 0 0 40 0
+    (auto-size (if (null? choices) (list "Choice") choices)
+               0 0 40 0
                (lambda (w h)
                  (set-size -11111 -11111 w (* h 8))))
 
@@ -85,6 +89,18 @@
 
     (define/public (number) num-choices)
 
-    (def/public-unimplemented clear)
+    (define/public (clear)
-    (def/public-unimplemented append)))
+      (atomically
+       (SendMessageW hwnd CB_RESETCONTENT 0 0)
+       (set! num-choices 0)))
+
+
+    (public [append* append])
+    (define (append* str)
+      (atomically
+       (SendMessageW/str hwnd CB_ADDSTRING 0 str)
+       (set! num-choices (add1 num-choices))
+       (when (= 1 num-choices) (set-selection 0))))))
+
+
 

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

@@ -598,6 +598,16 @@
 
 (define SW_SHOW 5)
 (define SW_HIDE 0)
+(define SW_SHOWNORMAL       1)
+(define SW_SHOWMINIMIZED    2)
+(define SW_SHOWMAXIMIZED    3)
+(define SW_MAXIMIZE         3)
+(define SW_SHOWNOACTIVATE   4)
+(define SW_MINIMIZE         6)
+(define SW_SHOWMINNOACTIVE  7)
+(define SW_RESTORE          9)
+(define SW_SHOWDEFAULT      10)
+(define SW_FORCEMINIMIZE    11)
 
 (define HORZRES       8)
 (define VERTRES       10)

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

@@ -24,9 +24,15 @@
 
 (define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int))
 
+(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL)
+                                  -> (unless r (failed 'DrawMenuBar))))
+
+(define-user32 IsZoomed (_wfun _HWND -> _BOOL))
+
 (define-user32 SystemParametersInfoW (_wfun _UINT _UINT _pointer _UINT -> (r : _BOOL)
                                             -> (unless r (failed 'SystemParametersInfo))))
 
+
 (define SPI_GETWORKAREA            #x0030)
 
 (define (display-size xb yb ?)
@@ -99,6 +105,9 @@
                      hInstance
                      #f))
 
+  (define saved-title (or label ""))
+  (define hidden-zoomed? #f)
+
   (super-new [parent #f]
 	     [hwnd (create-frame parent label w h style)]
 	     [style (cons 'invisible style)])
@@ -124,7 +133,11 @@
     ;; atomic mode
     (when (eq? mouse-frame this) (set! mouse-frame #f))
     (register-frame-shown this on?)
-    (super direct-show on?))
+    (when (and (not on?) (is-shown?))
+      (set! hidden-zoomed? (is-maximized?)))
+    (super direct-show on? (if hidden-zoomed?
+                               SW_SHOWMAXIMIZED
+                               SW_SHOW)))
 
   (define/private (stdret f d)
     (if (is-dialog?) d f))
@@ -275,9 +288,25 @@
 
   (def/public-unimplemented designate-root-frame)
   (def/public-unimplemented system-menu)
-  (def/public-unimplemented set-modified)
+
-  (def/public-unimplemented is-maximized?)
+  (define modified? #f)
-  (def/public-unimplemented maximize)
+  (define/public (set-modified on?)
+    (unless (eq? modified? (and on? #t))
+      (set! modified? (and on? #t))
+      (set-title saved-title)))
+
+  (define/public (is-maximized?)
+    (if (is-shown?)
+        hidden-zoomed?
+        (IsZoomed hwnd)))
+  
+  (define/public (maximize on?)
+    (if (is-shown?)
+        (set! hidden-zoomed? (and on? #t))
+        (ShowWindow hwnd (if on?
+                             SW_MAXIMIZE
+                             SW_RESTORE))))
+    
   (def/public-unimplemented iconized?)
   (def/public-unimplemented get-menu-bar)
 
@@ -286,6 +315,9 @@
     (atomically
      (set! menu-bar mb)
      (send mb set-parent this)))
+
+  (define/public (draw-menu-bar)
+    (DrawMenuBar hwnd))
   
   (define/override (is-frame?) #t)
 
@@ -294,5 +326,8 @@
 
   (def/public-unimplemented iconize)
   (define/public (set-title s)
-    (SetWindowTextW (get-hwnd) s)))
+    (atomically
+     (set! saved-title s)
+     (SetWindowTextW (get-hwnd) (string-append s (if modified? "*" ""))))))
+
 

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

@@ -1,5 +1,6 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/class
+(require racket/class
+         (only-in racket/list take drop)
          ffi/unsafe
          "../../lock.rkt"
          "../../syntax.rkt"
@@ -22,22 +23,35 @@
     (define hmenu (CreateMenu))
 
     (define menus null)
+    (define parent #f)
 
     (define/public (set-label-top pos str)
-      (void)) ;; FIXME
+      (send (list-ref menus pos) set-menu-label hmenu pos str)
+      (refresh))
       
     (def/public-unimplemented number)
     (def/public-unimplemented enable-top)
+
     (define/public (delete which pos)
-      (void)) ;; FIXME
+      (atomically
+       (set! menus (append (take menus pos)
+                           (drop menus (add1 pos))))
+       (RemoveMenu hmenu pos MF_BYPOSITION)
+       (refresh)))
+
+    (define/private (refresh)
+      (when parent
+        (send parent draw-menu-bar)))
 
     (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))))
+         (send m set-parent this lbl hmenu)))
+      (refresh))
 
     (define/public (set-parent f)
       (SetMenu (send f get-hwnd) hmenu)
-      (DrawMenuBar (send f get-hwnd)))))
+      (set! parent f)
+      (send parent draw-menu-bar))))

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

@@ -17,12 +17,6 @@
   (let ([wb (hash-ref ids id #f)])
     (and wb (weak-box-value wb))))
 
-(define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT))
-(define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD))
-(define-user32 ModifyMenuW (_wfun _HMENU _UINT _UINT _UINT_PTR _string/utf-16
-                                  -> (r : _BOOL)
-                                  -> (unless r (failed 'ModifyMenuW))))
-
 (defclass menu-item% object%
 
   (define id

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

@@ -48,6 +48,12 @@
         (proc (car items) pos)]
        [else (loop (cdr items) (add1 pos))])))
 
+  (define/public (set-menu-label bar-hmenu pos str)
+    (ModifyMenuW bar-hmenu pos
+                 (bitwise-ior MF_BYPOSITION MF_STRING MF_POPUP)
+                 (cast hmenu _HMENU _UINT_PTR)
+                 str))
+
   (define/public (set-label id str)
     (with-item
      id
@@ -78,9 +84,14 @@
      (lambda (i pos)
        (send i get-check hmenu pos))))
 
-  (def/public-unimplemented delete-by-position)
+  (define/public (delete-by-position pos)
+    (RemoveMenu hmenu pos MF_BYPOSITION))
+
   (define/public (delete id)
-    (void))
+    (with-item
+     id
+     (lambda (i pos)
+       (RemoveMenu hmenu pos MF_BYPOSITION))))
 
   (public [append-item append])
   (define (append-item id label help-str-or-submenu chckable?)

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

@@ -143,8 +143,7 @@
 
   (define/override (control-scrolled)
     (when value-hwnd
-      (let ([val (get-value)])
+      (set-text (get-value)))
-        (SetWindowTextW value-hwnd (format "~s" val))))
     (queue-window-event this (lambda ()
                                (callback this
                                          (new control-event%
@@ -152,7 +151,12 @@
                                               [time-stamp (current-milliseconds)])))))
 
   (define/public (set-value val)
-    (SendMessageW slider-hwnd TBM_SETPOS 1 val))
+    (SendMessageW slider-hwnd TBM_SETPOS 1 val)
+    (when value-hwnd
+      (set-text val)))
+  
+  (define/private (set-text val)
+    (SetWindowTextW value-hwnd (format "~s" val)))
     
   (define/public (get-value)
     (SendMessageW slider-hwnd TBM_GETPOS 0 0)))

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

@@ -113,5 +113,6 @@
   (bitwise-and v #xFFFF))
 
 (define (MAKELONG a b)
-  (bitwise-ior (arithmetic-shift b 16) a))
+  (bitwise-ior (arithmetic-shift b 16) 
+               (bitwise-and a #xFFFF)))
 (define (MAKELPARAM a b) (MAKELONG a b))

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

@@ -23,7 +23,11 @@
          SetCursor
          GetDC
          ReleaseDC
-         InvalidateRect)
+         InvalidateRect
+         GetMenuState
+         CheckMenuItem
+         ModifyMenuW
+         RemoveMenu)
 
 (define gdi32-lib (ffi-lib "gdi32.dll"))
 (define user32-lib (ffi-lib "user32.dll"))
@@ -72,3 +76,11 @@
 
 (define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
                                      -> (unless r (failed 'InvalidateRect))))
+
+(define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT))
+(define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD))
+(define-user32 ModifyMenuW (_wfun _HMENU _UINT _UINT _UINT_PTR _string/utf-16
+                                  -> (r : _BOOL)
+                                  -> (unless r (failed 'ModifyMenuW))))
+(define-user32 RemoveMenu (_wfun _HMENU _UINT _UINT -> (r : _BOOL)
+                                 -> (unless r (failed 'RemoveMenu))))

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

@@ -181,12 +181,12 @@
     (atomically (direct-show on?)))
 
   (define shown? #f)
-  (define/public (direct-show on?)
+  (define/public (direct-show on? [on-mode SW_SHOW])
     ;; atomic mode
     (set! shown? (and on? #t))
     (register-child-in-parent on?)
     (unless on? (not-focus-child this))
-    (ShowWindow hwnd (if on? SW_SHOW SW_HIDE)))
+    (ShowWindow hwnd (if on? on-mode SW_HIDE)))
   (unless (memq 'invisible style)
     (show #t))
   

collects/tests/gracket/item.rkt

@@ -6,7 +6,7 @@
 
 (define my-txt #f)
 (define my-lb #f)
-(define noisy? #t)
+(define noisy? #f)
 
 (define mdi-frame #f)
 (define (mdi)