suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: more menus and widgets

Browse Source 
original commit: 70b26a58855d66ee521171005189bc23f8b1e0fd
This commit is contained in:
Matthew Flatt 2010-10-01 20:12:22 -06:00
parent 428cf1577e
commit 536cf6582b
12 changed files with 131 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/mred/private/wx/win32/canvas.rkt
View File

@ -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)))))

22
collects/mred/private/wx/win32/choice.rkt
View File

@ -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))))))

10
collects/mred/private/wx/win32/const.rkt
View File

@ -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)

45
collects/mred/private/wx/win32/frame.rkt
View File

@ -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? "*" ""))))))

26
collects/mred/private/wx/win32/menu-bar.rkt
View File

@ -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))))

6
collects/mred/private/wx/win32/menu-item.rkt
View File

@ -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

15
collects/mred/private/wx/win32/menu.rkt
View File

@ -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?)

10
collects/mred/private/wx/win32/slider.rkt
View File

@ -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)))

3
collects/mred/private/wx/win32/types.rkt
View File

@ -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))

14
collects/mred/private/wx/win32/utils.rkt
View File

@ -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))))

4
collects/mred/private/wx/win32/window.rkt
View File

@ -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))

2
collects/tests/gracket/item.rkt
View File

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