diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 077e97e5..2a3f998e 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/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))))) + diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 383c9998..c71cdcbb 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/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) - (def/public-unimplemented append))) + (define/public (clear) + (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)))))) + + diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 6f2e9e6d..cfc0bd73 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/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) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index ff250eb5..87bf4e93 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/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?) - (def/public-unimplemented maximize) + + (define modified? #f) + (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? "*" "")))))) + diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index 3e1ea073..86a389c3 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -1,5 +1,6 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(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)))) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index daa901de..379d2db1 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/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 diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 5ed3cec0..33f22ecf 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/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?) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 320e530f..7ae2fedf 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -143,8 +143,7 @@ (define/override (control-scrolled) (when value-hwnd - (let ([val (get-value)]) - (SetWindowTextW value-hwnd (format "~s" val)))) + (set-text (get-value))) (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))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 26856830..f280b81f 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/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)) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 2c10cf68..95ed4e06 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ 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)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 2c381f8d..ba8c6590 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/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)) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index cff8412a..e8bd6f9a 100644 --- a/collects/tests/gracket/item.rkt +++ b/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)