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

win32 dialogs, etc.

Browse Source 
original commit: 1402583ad2775be07cb5f832101b1a1fc946ae65
This commit is contained in:
Matthew Flatt 2010-09-25 07:07:30 -06:00
parent 8980e91192
commit d7197a36db
14 changed files with 299 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mred/private/wx/win32/button.rkt
View File

@ -15,6 +15,8 @@
(provide base-button%
button%)
(define BM_SETSTYLE #x00F4)
(define base-button%
(class item%
(inherit set-control-font auto-size get-hwnd)
@ -72,7 +74,10 @@
[event-type 'button]
[time-stamp (current-milliseconds)])))))
(def/public-unimplemented set-border)))
(define/public (set-border on?)
(SendMessageW (get-hwnd) BM_SETSTYLE
(if on? BS_DEFPUSHBUTTON BS_PUSHBUTTON)
1))))
(define button%
(class base-button%

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

@ -79,7 +79,7 @@
(define hwnd (get-hwnd))
(define/override (wndproc w msg wParam lParam)
(define/override (wndproc w msg wParam lParam default)
(cond
[(= msg WM_PAINT)
(let* ([ps (malloc 128)]
@ -96,7 +96,7 @@
[(= msg WM_VSCROLL)
(on-scroll-change SB_VERT (LOWORD wParam))
0]
[else (super wndproc w msg wParam lParam)]))
[else (super wndproc w msg wParam lParam default)]))
(define dc (new dc% [canvas this]))
(send dc start-backing-retained)

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

@ -403,6 +403,7 @@
(define CW_USEDEFAULT #x80000000)
(define WS_EX_LAYERED #x00080000)
(define WS_EX_TRANSPARENT #x00000020)
(define LWA_ALPHA #x00000002)

100
collects/mred/private/wx/win32/dialog.rkt
View File

@ -1,14 +1,92 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt"
"window.rkt")
#lang racket/base
(require racket/class
(only-in racket/list last)
ffi/unsafe
"../../syntax.rkt"
"../../lock.rkt"
"../common/queue.rkt"
"../common/freeze.rkt"
"utils.ss"
"const.ss"
"types.ss"
"window.rkt"
"frame.rkt"
"wndclass.rkt")
(provide dialog%)
(defclass dialog% window%
(def/public-unimplemented system-menu)
(def/public-unimplemented set-title)
(def/public-unimplemented enforce-size)
(def/public-unimplemented on-close)
(def/public-unimplemented on-activate)
(super-new))
(define _WORD _short)
(define-cstruct _DLGTEMPLATE
([style _DWORD]
[dwExtendedStyle _DWORD]
[cdit _WORD]
[x _short]
[y _short]
[cx _short]
[cy _short]
[menu _short] ; 0
[class _short] ; 0
[title _short])) ; 0
(define _INT_PTR _long)
(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR))
(define DS_MODALFRAME #x80)
(define-user32 CreateDialogIndirectParamW (_wfun _HINSTANCE
_DLGTEMPLATE-pointer
_HWND
_fpointer
-> _HWND))
(define (dlgproc w msg wParam lParam)
(let ([wx (hwnd->wx w)])
(if wx
(send wx wndproc w msg wParam lParam
(lambda (w msg wParam lParam) 0))
0)))
(define dialog-proc (function-ptr dlgproc _DialogProc))
(define dialog-level-counter 0)
(define dialog%
(class frame%
(super-new)
(define/override (create-frame parent label w h)
(let ([hwnd
(CreateDialogIndirectParamW hInstance
(make-DLGTEMPLATE
(bitwise-ior DS_MODALFRAME WS_CAPTION WS_SYSMENU WS_THICKFRAME)
0 0
0 0 w h
0 0 0)
(and parent (send parent get-hwnd))
dialog-proc)])
(SetWindowTextW hwnd label)
(MoveWindow hwnd 0 0 w h #t)
hwnd))
(define/override (is-dialog?) #t)
(define dialog-level 0)
(define/override (get-dialog-level) dialog-level)
(define/override (frame-relative-dialog-status win)
(let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other])))
(define/override (direct-show on?)
(when on?
(set! dialog-level-counter (add1 dialog-level-counter))
(set! dialog-level dialog-level-counter))
(unless on?
(set! dialog-level 0))
(super direct-show on?))))

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

@ -6,9 +6,10 @@
"../../lock.rkt"
"../common/queue.rkt"
"../common/freeze.rkt"
"utils.ss"
"const.ss"
"types.ss"
"utils.rkt"
"const.rkt"
"types.rkt"
"theme.rkt"
"window.rkt"
"wndclass.rkt")
@ -30,17 +31,19 @@
on-size
pre-on-char pre-on-event)
(define/public (create-frame parent label w h)
(CreateWindowExW (bitwise-ior WS_EX_LAYERED)
"PLTFrame"
(if label label "")
WS_OVERLAPPEDWINDOW
0 0 w h
#f
#f
hInstance
#f))
(super-new [parent #f]
[hwnd
(CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED)
"PLTFrame"
(if label label "")
WS_OVERLAPPEDWINDOW
0 0 w h
#f
#f
hInstance
#f)]
[hwnd (create-frame parent label w h)]
[style (cons 'invisible style)])
(define hwnd (get-hwnd))
@ -67,7 +70,7 @@
(define/private (stdret f d)
(if (is-dialog?) d f))
(define/override (wndproc w msg wParam lParam)
(define/override (wndproc w msg wParam lParam default)
(cond
[(= msg WM_CLOSE)
(queue-window-event this (lambda ()
@ -99,7 +102,7 @@
(lambda () (on-menu-click))
(void))
0]
[else (super wndproc w msg wParam lParam)]))
[else (super wndproc w msg wParam lParam default)]))
(define/public (on-close) (void))
@ -147,15 +150,10 @@
(define/override (call-pre-on-char w e)
(pre-on-char w e))
(define dialog-level 0)
(define/override (get-dialog-level) 0)
(define/public (frame-relative-dialog-status win)
(cond
[(is-dialog?) (let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other]))]
[else #f]))
#f)
(def/public-unimplemented designate-root-frame)
(def/public-unimplemented system-menu)
@ -170,6 +168,8 @@
(atomically
(set! menu-bar mb)
(send mb set-parent this)))
(define/override (is-frame?) #t)
(def/public-unimplemented set-icon)
(def/public-unimplemented iconize)

4
collects/mred/private/wx/win32/group-panel.rkt
View File

@ -36,7 +36,7 @@
(define client-hwnd
(CreateWindowExW 0
"PLTPanel"
"PLTTabPanel"
#f
(bitwise-ior WS_CHILD WS_VISIBLE)
0 0 w h
@ -53,7 +53,7 @@
client-hwnd)
(define label-h 0)
(set-control-font #f)
(auto-size label 0 0 0 0
(lambda (w h)

2
collects/mred/private/wx/win32/message.rkt
View File

@ -35,7 +35,7 @@
(super-new [parent parent]
[hwnd
(CreateWindowExW 0
(CreateWindowExW (if (string? label) WS_EX_TRANSPARENT 0)
(get-class)
(if (string? label)
label

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

@ -30,7 +30,9 @@
(super-new [parent parent]
[hwnd
(CreateWindowExW 0
"PLTPanel"
(if (send parent is-frame?)
"PLTPanel"
"PLTTabPanel")
#f
(bitwise-ior WS_CHILD)
0 0 w h

5
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -34,7 +34,7 @@
(define hwnd
(CreateWindowExW 0
"PLTPanel"
"PLTTabPanel"
#f
(bitwise-ior WS_CHILD)
0 0 w h
@ -53,7 +53,8 @@
[bitmap? (and (label . is-a? . bitmap%)
(send label ok?))]
[radio-hwnd
(CreateWindowExW 0 "BUTTON"
(CreateWindowExW WS_EX_TRANSPARENT
"BUTTON"
(if (string? label)
label
"<image>")

103
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -1,9 +1,100 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt"
"window.rkt")
#lang racket/base
(require racket/class
ffi/unsafe
"../../syntax.rkt"
"../../lock.rkt"
"../common/event.rkt"
"item.rkt"
"utils.rkt"
"const.rkt"
"window.rkt"
"panel.rkt"
"wndclass.rkt"
"types.rkt")
(provide tab-panel%)
(defclass tab-panel% window%
(super-new))
(define TCIF_TEXT #x0001)
(define TCM_SETUNICODEFORMAT #x2005)
(define TCM_FIRST #x1300)
(define TCM_INSERTITEMW (+ TCM_FIRST 62))
(define-cstruct _TCITEMW
([mask _UINT]
[dwState _DWORD]
[dwStateMask _DWORD]
[pszText _permanent-string/utf-16]
[cchTextMax _int]
[iImage _int]
[lParam _LPARAM]))
(define tab-panel%
(class (panel-mixin window%)
(init parent
x y w h
style
choices)
(define callback void)
(inherit auto-size set-control-font)
(define hwnd
(CreateWindowExW 0
"SysTabControl32"
""
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0
(send parent get-client-hwnd)
#f
hInstance
#f))
(define client-hwnd
(CreateWindowExW 0
"PLTTabPanel"
#f
(bitwise-ior WS_CHILD WS_VISIBLE)
0 0 w h
hwnd
#f
hInstance
#f))
(super-new [parent parent]
[hwnd hwnd]
[style style])
(define/override (get-client-hwnd)
client-hwnd)
(SendMessageW hwnd TCM_SETUNICODEFORMAT 1 0)
(atomically
(let ([item (cast (malloc _TCITEMW 'raw) _pointer _TCITEMW-pointer)])
(set-TCITEMW-mask! item TCIF_TEXT)
(for ([i (in-list choices)]
[pos (in-naturals)])
(set-TCITEMW-pszText! item i)
(SendMessageW hwnd TCM_INSERTITEMW pos (cast item _pointer _LPARAM))
(free (TCITEMW-pszText item)))
(free item)))
(define tab-height 0)
(set-control-font #f)
(auto-size choices 0 0 0 0 #:combine-width +
(lambda (w h)
(set! tab-height (+ h 6))
(set-size -11111 -11111
(+ w (* 6 (length choices)))
(+ h 12))))
(define/override (set-size x y w h)
(super set-size x y w h)
(unless (or (= w -1) (= h -1))
(MoveWindow client-hwnd 1 (+ tab-height 2) (- w 4) (- h tab-height 6) #t)))
(define/public (set-callback cb)
(set! callback cb))))

12
collects/mred/private/wx/win32/theme.rkt
View File

@ -7,7 +7,9 @@
(provide get-theme-logfont
get-theme-font-face
get-theme-font-size
_LOGFONT-pointer)
_LOGFONT-pointer
DrawThemeParentBackground
EnableThemeDialogTexture)
(define _HTHEME (_cpointer 'HTHEME))
@ -59,6 +61,14 @@
(error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r))
f)))
(define-uxtheme DrawThemeParentBackground (_wfun _HWND _HDC _pointer -> (r : _HRESULT)
-> (when (negative? r)
(error 'DrawThemeParentBackground "failed: ~s" (bitwise-and #xFFFF r)))))
(define-uxtheme EnableThemeDialogTexture (_wfun _HWND _DWORD -> (r : _HRESULT)
-> (when (negative? r)
(error 'EnableThemeDialogTexture "failed: ~s" (bitwise-and #xFFFF r)))))
(define BP_PUSHBUTTON 1)
(define PBS_NORMAL 1)
(define TMT_FONT 210)

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

@ -83,9 +83,7 @@
(let ([c (malloc len _uint16 'raw)])
(memcpy c p len _uint16)
c))))))
(lambda (p)
(and p
(cast p _pointer _string/utf-16)))))
(lambda (p) p)))
(define _LONG _long)
(define _SHORT _short)

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

@ -22,6 +22,9 @@
(define (unhide-cursor) (void))
(define WM_PRINT #x0317)
(define WM_PRINTCLIENT #x0318)
(define-user32 CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
@ -35,6 +38,8 @@
(if r rect (failed 'GetClientRect))))
(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int)
-> (when (zero? r) (failed 'FillRect))))
(define-cstruct _NMHDR
([hwndFrom _HWND]
@ -51,6 +56,25 @@
(values (* 1/4 (bitwise-and v #xFFFF))
(* 1/8 (arithmetic-shift v -16)))))
(define-cstruct _LOGBRUSH
([lbStyle _UINT]
[lbColor _COLORREF]
[lbHatch _pointer]))
(define BS_NULL 1)
(define transparent-logbrush (make-LOGBRUSH BS_NULL 0 #f))
(define-gdi32 CreateBrushIndirect (_wfun _LOGBRUSH-pointer -> _HBRUSH))
(define TRANSPARENT 1)
(define-gdi32 SetBkMode (_wfun _HDC _int -> (r : _int)
-> (when (zero? r) (failed 'SetBkMode))))
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
-> (unless r (failed 'InvalidateRect))))
(defclass window% object%
(init-field parent hwnd)
(init style
@ -71,7 +95,7 @@
(define/public (is-hwnd? a-hwnd)
(ptr-equal? hwnd a-hwnd))
(define/public (wndproc w msg wParam lParam)
(define/public (wndproc w msg wParam lParam default)
(cond
[(= msg WM_SETFOCUS)
(queue-window-event this (lambda () (on-set-focus)))
@ -83,7 +107,7 @@
(when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close
(unhide-cursor)
(begin0
(DefWindowProcW w msg wParam lParam)
(default w msg wParam lParam)
(do-key wParam lParam #f #f)))]
[(= msg WM_KEYDOWN)
(do-key wParam lParam #f #f)
@ -95,7 +119,7 @@
(when (= wParam VK_MENU)
(unhide-cursor)
(begin0
(DefWindowProcW w msg wParam lParam)
(default w msg wParam lParam)
(do-key wParam lParam #t #f)))]
[(= msg WM_CHAR)
(do-key wParam lParam #t #f)
@ -107,7 +131,7 @@
(begin
(send wx do-command control-hwnd)
0)
(DefWindowProcW w msg wParam lParam)))]
(default w msg wParam lParam)))]
[(= msg WM_NOTIFY)
#;
(let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)]
@ -123,9 +147,9 @@
(begin
(send wx control-scrolled)
0)
(DefWindowProcW w msg wParam lParam)))]
(default w msg wParam lParam)))]
[else
(DefWindowProcW w msg wParam lParam)]))
(default w msg wParam lParam)]))
(define/public (is-command? cmd) #f)
(define/public (control-scrolled) #f)
@ -208,7 +232,9 @@
(define/public (auto-size label min-w min-h dw dh
[resize
(lambda (w h) (set-size -11111 -11111 w h))])
(lambda (w h) (set-size -11111 -11111 w h))]
#:combine-width [combine-w max]
#:combine-height [combine-h max])
(unless measure-dc
(let* ([bm (make-object bitmap% 1 1)]
[dc (make-object bitmap-dc% bm)]
@ -228,8 +254,8 @@
(loop (car label))]
[(w2 h2 d2 a2)
(loop (cdr label))])
(values (max w1 w2) (max h1 h2)
(max d1 d1) (max a1 a2)))]
(values (combine-w w1 w2) (combine-h h1 h2)
(combine-h d1 d1) (combine-h a1 a2)))]
[else
(send measure-dc get-text-extent label #f #t)]))]
[(->int) (lambda (v) (inexact->exact (floor v)))])
@ -240,6 +266,7 @@
(def/public-unimplemented center)
(define/public (get-parent) parent)
(define/public (is-frame?) #f)
(define/public (refresh) (void))
(define/public (on-resized) (void))
@ -337,7 +364,9 @@
;; re-sync the display in case a stream of
;; events (e.g., key repeat) have a corresponding
;; stream of screen updates.
(void)))
(void))
(define/public (get-dialog-level) (send parent get-dialog-level)))
;; ----------------------------------------

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

@ -74,6 +74,9 @@
(define-user32 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR))
(define-user32 LoadIconW (_wfun _HINSTANCE _pointer -> _HICON))
(define-user32 GetClassInfoW (_wfun _HINSTANCE _string/utf-16 (i : (_ptr o _WNDCLASS)) -> (r : _BOOL)
-> (if r i (failed 'GetClassInfoW))))
(define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
#;(define-user32 PostQuitMessage (_wfun _int -> _void))
@ -81,7 +84,7 @@
(define (wind-proc w msg wparam lparam)
(let ([wx (hwnd->wx w)])
(if wx
(send wx wndproc w msg wparam lparam)
(send wx wndproc w msg wparam lparam DefWindowProcW)
(DefWindowProcW w msg wparam lparam))))
(define hInstance (GetModuleHandleW #f))
@ -125,4 +128,21 @@
#f ; menu
"PLTPanel")))
(define controls-are-transparent? #f)
(void (RegisterClassW (make-WNDCLASS 0
wind-proc
0
0
hInstance
#f
(LoadCursorW #f IDC_ARROW)
(if controls-are-transparent?
#f ; transparent
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
(cpointer-push-tag! p 'HBRUSH)
p))
#f ; menu
"PLTTabPanel")))
(define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int))