332 lines
11 KiB
Racket
332 lines
11 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/alloc
|
|
racket/class
|
|
"../../lock.rkt"
|
|
"../common/utils.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"icons.rkt")
|
|
|
|
(provide
|
|
(protect-out hInstance
|
|
DefWindowProcW
|
|
background-hbrush
|
|
set-hwnd-wx!
|
|
hwnd->wx
|
|
hwnd->ctlproc
|
|
any-hwnd->wx
|
|
CreateWindowExW
|
|
CreateWindowExW/control
|
|
CreateDialogIndirectParamW dialog-proc
|
|
clean-up-destroyed
|
|
MessageBoxW
|
|
_WndProc
|
|
app-icon))
|
|
|
|
;; ----------------------------------------
|
|
;; We use the "user data" field of an HWND to
|
|
;; store a weak pointer back to the Racket object.
|
|
;; The weak pointer must be wrapped in an immuable cell.
|
|
;; In addition, if we need to save a control's old
|
|
;; ctlproc, we put it in the same immutable cell.
|
|
|
|
(define all-hwnds (make-hash))
|
|
|
|
;; call in atomic mode:
|
|
(define (register-hwnd! hwnd)
|
|
(hash-set! all-hwnds (cast hwnd _pointer _intptr) #t)
|
|
(let ([c (malloc-immobile-cell (vector #f #f #f))])
|
|
(void (SetWindowLongPtrW hwnd GWLP_USERDATA c))))
|
|
|
|
(define (set-hwnd-wx! hwnd wx)
|
|
(let* ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]
|
|
[v (ptr-ref c _racket)])
|
|
(vector-set! v 0 (make-weak-box wx))))
|
|
|
|
(define (set-hwnd-ctlproc! hwnd save-ptr ctlproc)
|
|
(let* ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]
|
|
[v (ptr-ref c _racket)])
|
|
(vector-set! v 1 ctlproc)
|
|
(vector-set! v 2 save-ptr)))
|
|
|
|
(define (hwnd->wx hwnd)
|
|
(let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)])
|
|
(and c (let ([v (ptr-ref c _racket)])
|
|
(and v
|
|
(let ([wb (vector-ref v 0)])
|
|
(and wb
|
|
(weak-box-value wb))))))))
|
|
|
|
(define (any-hwnd->wx hwnd)
|
|
(and
|
|
(atomically (hash-ref all-hwnds (cast hwnd _pointer _intptr) #f))
|
|
(let ([wx (hwnd->wx hwnd)])
|
|
(and wx
|
|
(send wx is-hwnd? hwnd)
|
|
wx))))
|
|
|
|
(define (hwnd->ctlproc hwnd)
|
|
(let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)])
|
|
(and c (let ([v (ptr-ref c _racket)])
|
|
(and v (vector-ref v 1))))))
|
|
|
|
(define (hwnd->ctlproc-fptr hwnd)
|
|
(let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)])
|
|
(and c (let ([v (ptr-ref c _racket)])
|
|
(and v (vector-ref v 2))))))
|
|
|
|
;; call in atomic mode:
|
|
(define (can-unregister-hwnd? hwnd)
|
|
(hash-ref all-hwnds (cast hwnd _pointer _intptr) #f))
|
|
|
|
;; call in atomic mode:
|
|
(define (unregister-hwnd! hwnd)
|
|
(let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)])
|
|
(when c
|
|
(free-immobile-cell c)
|
|
(SetWindowLongPtrW hwnd GWLP_USERDATA #f))
|
|
(hash-remove! all-hwnds (cast hwnd _pointer _intptr))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-cstruct _INITCOMMONCONTROLSEX
|
|
([dwSize _DWORD]
|
|
[dwICC _DWORD]))
|
|
|
|
(define-comctl32 InitCommonControlsEx (_wfun _INITCOMMONCONTROLSEX-pointer -> _BOOL))
|
|
|
|
(void
|
|
(InitCommonControlsEx (make-INITCOMMONCONTROLSEX
|
|
(ctype-sizeof _INITCOMMONCONTROLSEX)
|
|
0)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define _WndProc (_wfun #:atomic? #t #:keep (box null)
|
|
_HWND _UINT _WPARAM _LPARAM -> _LRESULT))
|
|
|
|
(define (wind-proc w msg wparam lparam)
|
|
(if (= msg WM_DESTROY)
|
|
(begin
|
|
(unregister-hwnd! w)
|
|
(DefWindowProcW w msg wparam lparam))
|
|
(let ([wx (hwnd->wx w)])
|
|
(if wx
|
|
(send wx wndproc w msg wparam lparam DefWindowProcW)
|
|
(DefWindowProcW w msg wparam lparam)))))
|
|
|
|
(define wind-proc-ptr (function-ptr wind-proc _WndProc))
|
|
|
|
(define-user32 CallWindowProcW (_wfun _fpointer _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
|
|
|
|
(define (control-proc w msg wParam lParam)
|
|
(let ([default-ctlproc (hwnd->ctlproc-fptr w)])
|
|
(if (= msg WM_DESTROY)
|
|
(begin
|
|
(SetWindowLongPtrW w GWLP_WNDPROC (hwnd->ctlproc-fptr w))
|
|
(unregister-hwnd! w)
|
|
(CallWindowProcW default-ctlproc w msg wParam lParam))
|
|
(let ([wx (hwnd->wx w)])
|
|
(if wx
|
|
(send wx ctlproc w msg wParam lParam
|
|
(lambda (w msg wParam lParam)
|
|
(CallWindowProcW default-ctlproc w msg wParam lParam)))
|
|
(CallWindowProcW default-ctlproc w msg wParam lParam))))))
|
|
|
|
(define control_proc (function-ptr control-proc _WndProc))
|
|
|
|
(define (subclass-control hwnd)
|
|
(let* ([fptr (GetWindowLongPtrW hwnd GWLP_WNDPROC)]
|
|
[old-control-proc (function-ptr fptr _WndProc)])
|
|
(set-hwnd-ctlproc! hwnd fptr old-control-proc)
|
|
(SetWindowLongPtrW hwnd GWLP_WNDPROC control_proc)))
|
|
|
|
|
|
(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR))
|
|
|
|
(define (dlgproc w msg wParam lParam)
|
|
(if (= msg WM_DESTROY)
|
|
(begin
|
|
(unregister-hwnd! w)
|
|
0)
|
|
(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-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
|
|
-> (unless r (failed 'DestroyWindow))))
|
|
|
|
(define (maybe-destroy-window hwnd)
|
|
(atomically
|
|
(when (can-unregister-hwnd? hwnd)
|
|
(DestroyWindow hwnd))))
|
|
|
|
(define (clean-up-destroyed)
|
|
(free-remembered-now maybe-destroy-window))
|
|
|
|
(define-user32 _CreateWindowExW (_wfun _DWORD
|
|
_string/utf-16
|
|
_string/utf-16
|
|
_UDWORD
|
|
_int _int _int _int
|
|
_HWND _HMENU _HINSTANCE _pointer
|
|
-> _HWND)
|
|
#:c-id CreateWindowExW)
|
|
|
|
(define (make-CreateWindowEx register!)
|
|
((allocator remember-to-free-later)
|
|
(lambda (dwExStyle lpClassName lpWindowName dwStyle
|
|
x y nWidth nHeight
|
|
hWndParent hMenu hInstance lpParam)
|
|
(let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle
|
|
x y nWidth nHeight
|
|
hWndParent hMenu hInstance lpParam)])
|
|
(register! hwnd)
|
|
hwnd))))
|
|
|
|
(define CreateWindowExW (make-CreateWindowEx register-hwnd!))
|
|
(define CreateWindowExW/control (make-CreateWindowEx (lambda (hwnd)
|
|
(register-hwnd! hwnd)
|
|
(subclass-control hwnd))))
|
|
|
|
|
|
(define-user32 _CreateDialogIndirectParamW (_wfun _HINSTANCE
|
|
_pointer ; _DLGTEMPLATE-pointer
|
|
_HWND
|
|
_fpointer
|
|
_LPARAM
|
|
-> _HWND)
|
|
#:c-id CreateDialogIndirectParamW)
|
|
|
|
(define CreateDialogIndirectParamW
|
|
((allocator remember-to-free-later)
|
|
(lambda (hInstance lpTemplate hWndParent lpDialogFunc lParamInit)
|
|
(let ([hwnd (_CreateDialogIndirectParamW
|
|
hInstance lpTemplate hWndParent lpDialogFunc lParamInit)])
|
|
(register-hwnd! hwnd)
|
|
hwnd))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-cstruct _WNDCLASS ([style _UINT]
|
|
[lpfnWndProc _fpointer]
|
|
[cbClsExtra _int]
|
|
[cbWndExtra _int]
|
|
[hInstace _HINSTANCE]
|
|
[hIcon _HICON]
|
|
[hCursor _HCURSOR]
|
|
[hbrBackground _HBRUSH]
|
|
[lpszMenuName _permanent-string/utf-16]
|
|
[lpszClassName _permanent-string/utf-16]))
|
|
|
|
(define-user32 RegisterClassW (_wfun _WNDCLASS-pointer -> _ATOM))
|
|
(define-kernel32 GetModuleHandleW (_wfun _pointer -> _HINSTANCE))
|
|
|
|
(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 DefWindowProcW/raw _fpointer
|
|
#:c-id DefWindowProcW)
|
|
|
|
#;(define-user32 PostQuitMessage (_wfun _int -> _void))
|
|
|
|
(define hInstance (GetModuleHandleW #f))
|
|
|
|
(define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
|
|
(cpointer-push-tag! p 'HBRUSH)
|
|
p))
|
|
|
|
(define-kernel32 GetModuleFileNameW (_wfun #:save-errno 'windows _pointer _pointer _DWORD -> _DWORD))
|
|
(define ERROR_INSUFFICIENT_BUFFER 122)
|
|
(define-shell32 ExtractIconW (_wfun _HINSTANCE _string/utf-16 _UINT -> (r : _HICON)
|
|
-> (or r (failed 'ExtractIconW))))
|
|
|
|
(define app-icon
|
|
(let ([path
|
|
(let loop ([size 1024])
|
|
(let ([p (make-bytes (* (ctype-sizeof _WCHAR) 1024))])
|
|
(let ([r (GetModuleFileNameW #f p size)])
|
|
(cond
|
|
[(and (or (zero? r) (= r size))
|
|
(= (saved-errno) ERROR_INSUFFICIENT_BUFFER))
|
|
(loop (* size 2))]
|
|
[(zero? r) (failed 'GetModuleFileNameW)]
|
|
[else (cast p _gcpointer _string/utf-16)]))))])
|
|
(if path
|
|
(ExtractIconW hInstance path 0)
|
|
(LoadIconW #f IDI_APPLICATION))))
|
|
|
|
(void (RegisterClassW (make-WNDCLASS CS_OWNDC
|
|
wind-proc-ptr
|
|
0
|
|
0
|
|
hInstance
|
|
app-icon
|
|
#f
|
|
background-hbrush
|
|
#f ; menu
|
|
"PLTFrame")))
|
|
|
|
(void (RegisterClassW (make-WNDCLASS 0 ; using CS_OWNDC creates trouble when resizing?
|
|
wind-proc-ptr
|
|
0
|
|
0
|
|
hInstance
|
|
#f
|
|
#f
|
|
#f ; transparent
|
|
#f ; menu
|
|
"PLTCanvas")))
|
|
|
|
(void (RegisterClassW (make-WNDCLASS 0
|
|
wind-proc-ptr
|
|
0
|
|
0
|
|
hInstance
|
|
#f
|
|
#f
|
|
background-hbrush
|
|
#f ; menu
|
|
"PLTPanel")))
|
|
|
|
(define controls-are-transparent? #f)
|
|
|
|
(void (RegisterClassW (make-WNDCLASS 0
|
|
wind-proc-ptr
|
|
0
|
|
0
|
|
hInstance
|
|
#f
|
|
#f
|
|
(if controls-are-transparent?
|
|
#f ; transparent
|
|
background-hbrush)
|
|
#f ; menu
|
|
"PLTTabPanel")))
|
|
|
|
(define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int))
|
|
|
|
(define (register-no-cursor orig-name)
|
|
(let ([i (GetClassInfoW hInstance orig-name)])
|
|
(set-WNDCLASS-lpszClassName! i (string-append "PLT" orig-name))
|
|
(set-WNDCLASS-hCursor! i #f)
|
|
(void (RegisterClassW i))))
|
|
|
|
(register-no-cursor "BUTTON")
|
|
(register-no-cursor "STATIC")
|
|
(register-no-cursor "LISTBOX")
|
|
(register-no-cursor "COMBOBOX")
|
|
(register-no-cursor "msctls_trackbar32")
|
|
(register-no-cursor "msctls_progress32")
|
|
(register-no-cursor "SysTabControl32")
|
|
(register-no-cursor "SysListView32")
|