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

win32 beginnings

Browse Source 
original commit: aaf06368175911b92579af1666bfe6262aaf99fe
This commit is contained in:
Matthew Flatt 2010-09-20 06:56:43 -06:00
parent b92d693343
commit 18ad972f3f
15 changed files with 999 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,10 +1,32 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt"
"item.rkt")
"item.rkt"
"utils.rkt"
"const.rkt"
"window.rkt"
"wndclass.rkt")
(provide button%)
(defclass button% item%
(def/public-unimplemented set-border)
(super-new))
(inherit auto-size)
(init parent cb label x y w h style font)
(super-new [parent parent]
[win32
(CreateWindowExW 0
"BUTTON"
label
(bitwise-ior BS_PUSHBUTTON WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0
(send parent get-win32)
#f
hInstance
#f)]
[style style])
(auto-size label 50 14)
(def/public-unimplemented set-border))

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

@ -27,4 +27,6 @@
(def/public-unimplemented on-char)
(def/public-unimplemented on-event)
(def/public-unimplemented on-paint)
(def/public-unimplemented begin-refresh-sequence)
(def/public-unimplemented end-refresh-sequence)
(super-new))

413
collects/mred/private/wx/win32/const.rkt Normal file
View File

@ -0,0 +1,413 @@
#lang scheme/base
(provide (all-defined-out))
(define WM_NULL #x0000)
(define WM_CREATE #x0001)
(define WM_DESTROY #x0002)
(define WM_MOVE #x0003)
(define WM_SIZE #x0005)
(define WM_ACTIVATE #x0006)
;; WM_ACTIVATE state values
(define WA_INACTIVE 0)
(define WA_ACTIVE 1)
(define WA_CLICKACTIVE 2)
(define WM_SETFOCUS #x0007)
(define WM_KILLFOCUS #x0008)
(define WM_ENABLE #x000A)
(define WM_SETREDRAW #x000B)
(define WM_SETTEXT #x000C)
(define WM_GETTEXT #x000D)
(define WM_GETTEXTLENGTH #x000E)
(define WM_PAINT #x000F)
(define WM_CLOSE #x0010)
(define WM_QUIT #x0012)
(define WM_ERASEBKGND #x0014)
(define WM_SYSCOLORCHANGE #x0015)
(define WM_SHOWWINDOW #x0018)
(define WM_WININICHANGE #x001A)
(define WM_SETTINGCHANGE WM_WININICHANGE)
(define WM_DEVMODECHANGE #x001B)
(define WM_ACTIVATEAPP #x001C)
(define WM_FONTCHANGE #x001D)
(define WM_TIMECHANGE #x001E)
(define WM_CANCELMODE #x001F)
(define WM_SETCURSOR #x0020)
(define WM_MOUSEACTIVATE #x0021)
(define WM_CHILDACTIVATE #x0022)
(define WM_QUEUESYNC #x0023)
(define WM_GETMINMAXINFO #x0024)
(define WM_PAINTICON #x0026)
(define WM_ICONERASEBKGND #x0027)
(define WM_NEXTDLGCTL #x0028)
(define WM_SPOOLERSTATUS #x002A)
(define WM_DRAWITEM #x002B)
(define WM_MEASUREITEM #x002C)
(define WM_DELETEITEM #x002D)
(define WM_VKEYTOITEM #x002E)
(define WM_CHARTOITEM #x002F)
(define WM_SETFONT #x0030)
(define WM_GETFONT #x0031)
(define WM_SETHOTKEY #x0032)
(define WM_GETHOTKEY #x0033)
(define WM_QUERYDRAGICON #x0037)
(define WM_COMPAREITEM #x0039)
(define WM_GETOBJECT #x003D)
(define WM_COMPACTING #x0041)
(define WM_WINDOWPOSCHANGING #x0046)
(define WM_WINDOWPOSCHANGED #x0047)
(define WM_POWER #x0048)
;; wParam for WM_POWER window message and DRV_POWER driver notification
(define PWR_OK 1)
(define PWR_FAIL -1)
(define PWR_SUSPENDREQUEST 1)
(define PWR_SUSPENDRESUME 2)
(define PWR_CRITICALRESUME 3)
(define WM_COPYDATA #x004A)
(define WM_CANCELJOURNAL #x004B)
(define WM_NOTIFY #x004E)
(define WM_INPUTLANGCHANGEREQUEST #x0050)
(define WM_INPUTLANGCHANGE #x0051)
(define WM_TCARD #x0052)
(define WM_HELP #x0053)
(define WM_USERCHANGED #x0054)
(define WM_NOTIFYFORMAT #x0055)
(define NFR_ANSI 1)
(define NFR_UNICODE 2)
(define NF_QUERY 3)
(define NF_REQUERY 4)
(define WM_CONTEXTMENU #x007B)
(define WM_STYLECHANGING #x007C)
(define WM_STYLECHANGED #x007D)
(define WM_DISPLAYCHANGE #x007E)
(define WM_GETICON #x007F)
(define WM_SETICON #x0080)
(define WM_NCCREATE #x0081)
(define WM_NCDESTROY #x0082)
(define WM_NCCALCSIZE #x0083)
(define WM_NCHITTEST #x0084)
(define WM_NCPAINT #x0085)
(define WM_NCACTIVATE #x0086)
(define WM_GETDLGCODE #x0087)
(define WM_NCMOUSEMOVE #x00A0)
(define WM_NCLBUTTONDOWN #x00A1)
(define WM_NCLBUTTONUP #x00A2)
(define WM_NCLBUTTONDBLCLK #x00A3)
(define WM_NCRBUTTONDOWN #x00A4)
(define WM_NCRBUTTONUP #x00A5)
(define WM_NCRBUTTONDBLCLK #x00A6)
(define WM_NCMBUTTONDOWN #x00A7)
(define WM_NCMBUTTONUP #x00A8)
(define WM_NCMBUTTONDBLCLK #x00A9)
(define WM_NCXBUTTONDOWN #x00AB)
(define WM_NCXBUTTONUP #x00AC)
(define WM_NCXBUTTONDBLCLK #x00AD)
(define WM_INPUT #x00FF)
(define WM_KEYFIRST #x0100)
(define WM_KEYDOWN #x0100)
(define WM_KEYUP #x0101)
(define WM_CHAR #x0102)
(define WM_DEADCHAR #x0103)
(define WM_SYSKEYDOWN #x0104)
(define WM_SYSKEYUP #x0105)
(define WM_SYSCHAR #x0106)
(define WM_SYSDEADCHAR #x0107)
(define WM_UNICHAR #x0109)
(define WM_KEYLAST #x0109)
(define UNICODE_NOCHAR #xFFFF)
(define WM_IME_STARTCOMPOSITION #x010D)
(define WM_IME_ENDCOMPOSITION #x010E)
(define WM_IME_COMPOSITION #x010F)
(define WM_IME_KEYLAST #x010F)
(define WM_INITDIALOG #x0110)
(define WM_COMMAND #x0111)
(define WM_SYSCOMMAND #x0112)
(define WM_TIMER #x0113)
(define WM_HSCROLL #x0114)
(define WM_VSCROLL #x0115)
(define WM_INITMENU #x0116)
(define WM_INITMENUPOPUP #x0117)
(define WM_MENUSELECT #x011F)
(define WM_MENUCHAR #x0120)
(define WM_ENTERIDLE #x0121)
(define WM_MENURBUTTONUP #x0122)
(define WM_MENUDRAG #x0123)
(define WM_MENUGETOBJECT #x0124)
(define WM_UNINITMENUPOPUP #x0125)
(define WM_MENUCOMMAND #x0126)
(define WM_CHANGEUISTATE #x0127)
(define WM_UPDATEUISTATE #x0128)
(define WM_QUERYUISTATE #x0129)
;; LOWORD(wParam) values in WM_*UISTATE*
(define UIS_SET 1)
(define UIS_CLEAR 2)
(define UIS_INITIALIZE 3)
;; HIWORD(wParam) values in WM_*UISTATE*
(define UISF_HIDEFOCUS #x1)
(define UISF_HIDEACCEL #x2)
(define UISF_ACTIVE #x4)
(define WM_CTLCOLORMSGBOX #x0132)
(define WM_CTLCOLOREDIT #x0133)
(define WM_CTLCOLORLISTBOX #x0134)
(define WM_CTLCOLORBTN #x0135)
(define WM_CTLCOLORDLG #x0136)
(define WM_CTLCOLORSCROLLBAR #x0137)
(define WM_CTLCOLORSTATIC #x0138)
(define MN_GETHMENU #x01E1)
(define WM_MOUSEFIRST #x0200)
(define WM_MOUSEMOVE #x0200)
(define WM_LBUTTONDOWN #x0201)
(define WM_LBUTTONUP #x0202)
(define WM_LBUTTONDBLCLK #x0203)
(define WM_RBUTTONDOWN #x0204)
(define WM_RBUTTONUP #x0205)
(define WM_RBUTTONDBLCLK #x0206)
(define WM_MBUTTONDOWN #x0207)
(define WM_MBUTTONUP #x0208)
(define WM_MBUTTONDBLCLK #x0209)
(define WM_MOUSEWHEEL #x020A)
(define WM_XBUTTONDOWN #x020B)
(define WM_XBUTTONUP #x020C)
(define WM_XBUTTONDBLCLK #x020D)
(define WM_MOUSELAST #x020D)
;; Value for rolling one detent
(define WHEEL_DELTA 120)
;; (define WHEEL_PAGESCROLL UINT_MAX)
;; XButton values are WORD flags
(define XBUTTON1 #x0001)
(define XBUTTON2 #x0002)
(define WM_PARENTNOTIFY #x0210)
(define WM_ENTERMENULOOP #x0211)
(define WM_EXITMENULOOP #x0212)
(define WM_NEXTMENU #x0213)
(define WM_SIZING #x0214)
(define WM_CAPTURECHANGED #x0215)
(define WM_MOVING #x0216)
(define WM_DEVICECHANGE #x0219)
(define WM_MDICREATE #x0220)
(define WM_MDIDESTROY #x0221)
(define WM_MDIACTIVATE #x0222)
(define WM_MDIRESTORE #x0223)
(define WM_MDINEXT #x0224)
(define WM_MDIMAXIMIZE #x0225)
(define WM_MDITILE #x0226)
(define WM_MDICASCADE #x0227)
(define WM_MDIICONARRANGE #x0228)
(define WM_MDIGETACTIVE #x0229)
(define WM_MDISETMENU #x0230)
(define WM_ENTERSIZEMOVE #x0231)
(define WM_EXITSIZEMOVE #x0232)
(define WM_DROPFILES #x0233)
(define WM_MDIREFRESHMENU #x0234)
(define WM_IME_SETCONTEXT #x0281)
(define WM_IME_NOTIFY #x0282)
(define WM_IME_CONTROL #x0283)
(define WM_IME_COMPOSITIONFULL #x0284)
(define WM_IME_SELECT #x0285)
(define WM_IME_CHAR #x0286)
(define WM_IME_REQUEST #x0288)
(define WM_IME_KEYDOWN #x0290)
(define WM_IME_KEYUP #x0291)
(define WM_MOUSEHOVER #x02A1)
(define WM_MOUSELEAVE #x02A3)
(define WM_NCMOUSEHOVER #x02A0)
(define WM_NCMOUSELEAVE #x02A2)
(define WM_WTSSESSION_CHANGE #x02B1)
(define WM_TABLET_FIRST #x02c0)
(define WM_TABLET_LAST #x02df)
(define WM_CUT #x0300)
(define WM_COPY #x0301)
(define WM_PASTE #x0302)
(define WM_CLEAR #x0303)
(define WM_UNDO #x0304)
(define WM_RENDERFORMAT #x0305)
(define WM_RENDERALLFORMATS #x0306)
(define WM_DESTROYCLIPBOARD #x0307)
(define WM_DRAWCLIPBOARD #x0308)
(define WM_PAINTCLIPBOARD #x0309)
(define WM_VSCROLLCLIPBOARD #x030A)
(define WM_SIZECLIPBOARD #x030B)
(define WM_ASKCBFORMATNAME #x030C)
(define WM_CHANGECBCHAIN #x030D)
(define WM_HSCROLLCLIPBOARD #x030E)
(define WM_QUERYNEWPALETTE #x030F)
(define WM_PALETTEISCHANGING #x0310)
(define WM_PALETTECHANGED #x0311)
(define WM_HOTKEY #x0312)
;; Class styles
(define CS_VREDRAW #x0001)
(define CS_HREDRAW #x0002)
(define CS_DBLCLKS #x0008)
(define CS_OWNDC #x0020)
(define CS_CLASSDC #x0040)
(define CS_PARENTDC #x0080)
(define CS_NOCLOSE #x0200)
(define CS_SAVEBITS #x0800)
(define CS_BYTEALIGNCLIENT #x1000)
(define CS_BYTEALIGNWINDOW #x2000)
(define CS_GLOBALCLASS #x4000)
;; Window styles
(define WS_OVERLAPPED #x00000000)
(define WS_POPUP #x80000000)
(define WS_CHILD #x40000000)
(define WS_CLIPSIBLINGS #x04000000)
(define WS_CLIPCHILDREN #x02000000)
(define WS_VISIBLE #x10000000)
(define WS_DISABLED #x08000000)
(define WS_MINIMIZE #x20000000)
(define WS_MAXIMIZE #x01000000)
(define WS_CAPTION #x00C00000)
(define WS_BORDER #x00800000)
(define WS_DLGFRAME #x00400000)
(define WS_VSCROLL #x00200000)
(define WS_HSCROLL #x00100000)
(define WS_SYSMENU #x00080000)
(define WS_THICKFRAME #x00040000)
(define WS_MINIMIZEBOX #x00020000)
(define WS_MAXIMIZEBOX #x00010000)
(define WS_GROUP #x00020000)
(define WS_TABSTOP #x00010000)
(define WS_OVERLAPPEDWINDOW (bitwise-ior WS_OVERLAPPED WS_CAPTION WS_SYSMENU
WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX))
(define PM_NOREMOVE #x0000)
(define PM_REMOVE #x0001)
(define PM_NOYIELD #x0002)
(define QS_KEY #x0001)
(define QS_MOUSEMOVE #x0002)
(define QS_MOUSEBUTTON #x0004)
(define QS_POSTMESSAGE #x0008)
(define QS_TIMER #x0010)
(define QS_PAINT #x0020)
(define QS_SENDMESSAGE #x0040)
(define QS_HOTKEY #x0080)
(define QS_ALLPOSTMESSAGE #x0100)
(define QS_RAWINPUT #x0400)
(define QS_MOUSE (bitwise-ior QS_MOUSEMOVE
QS_MOUSEBUTTON))
(define QS_INPUT (bitwise-ior QS_MOUSE
QS_KEY
QS_RAWINPUT))
(define QS_ALLEVENTS (bitwise-ior QS_INPUT
QS_POSTMESSAGE
QS_TIMER
QS_PAINT
QS_HOTKEY))
(define QS_ALLINPUT (bitwise-ior QS_INPUT
QS_POSTMESSAGE
QS_TIMER
QS_PAINT
QS_HOTKEY
QS_SENDMESSAGE))
(define GWLP_WNDPROC -4)
(define GWLP_USERDATA -21)
(define COLOR_SCROLLBAR 0)
(define COLOR_BACKGROUND 1)
(define COLOR_ACTIVECAPTION 2)
(define COLOR_INACTIVECAPTION 3)
(define COLOR_MENU 4)
(define COLOR_WINDOW 5)
(define COLOR_WINDOWFRAME 6)
(define COLOR_MENUTEXT 7)
(define COLOR_WINDOWTEXT 8)
(define COLOR_CAPTIONTEXT 9)
(define COLOR_ACTIVEBORDER 10)
(define COLOR_INACTIVEBORDER 11)
(define COLOR_APPWORKSPACE 12)
(define COLOR_HIGHLIGHT 13)
(define COLOR_HIGHLIGHTTEXT 14)
(define COLOR_BTNFACE 15)
(define COLOR_BTNSHADOW 16)
(define COLOR_GRAYTEXT 17)
(define COLOR_BTNTEXT 18)
(define COLOR_INACTIVECAPTIONTEXT 19)
(define COLOR_BTNHIGHLIGHT 20)
(define BS_PUSHBUTTON #x00000000)
(define BS_DEFPUSHBUTTON #x00000001)
(define BS_CHECKBOX #x00000002)
(define BS_AUTOCHECKBOX #x00000003)
(define BS_RADIOBUTTON #x00000004)
(define BS_3STATE #x00000005)
(define BS_AUTO3STATE #x00000006)
(define BS_GROUPBOX #x00000007)
(define BS_USERBUTTON #x00000008)
(define BS_AUTORADIOBUTTON #x00000009)
(define BS_PUSHBOX #x0000000A)
(define BS_OWNERDRAW #x0000000B)
(define BS_TYPEMASK #x0000000F)
(define BS_LEFTTEXT #x00000020)
(define BS_TEXT #x00000000)
(define BS_ICON #x00000040)
(define BS_BITMAP #x00000080)
(define BS_LEFT #x00000100)
(define BS_RIGHT #x00000200)
(define BS_CENTER #x00000300)
(define BS_TOP #x00000400)
(define BS_BOTTOM #x00000800)
(define BS_VCENTER #x00000C00)
(define BS_PUSHLIKE #x00001000)
(define BS_MULTILINE #x00002000)
(define BS_NOTIFY #x00004000)
(define BS_FLAT #x00008000)
(define BS_RIGHTBUTTON BS_LEFTTEXT)
(define CW_USEDEFAULT #x80000000)
(define WS_EX_LAYERED #x00080000)
(define LWA_ALPHA #x00000002)
(define MB_OK #x00000000)
(define MB_OKCANCEL #x00000001)
(define MB_ABORTRETRYIGNORE #x00000002)
(define MB_YESNOCANCEL #x00000003)
(define MB_YESNO #x00000004)
(define MB_RETRYCANCEL #x00000005)

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

@ -5,5 +5,7 @@
(provide cursor-driver%)
(defclass cursor-driver% object%
(define/public (set-standard c) (void))
(def/public-unimplemented ok?)
(super-new))

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

@ -1,17 +1,90 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt"
"window.rkt")
#lang racket/base
(require racket/class
"../../syntax.rkt"
"../common/queue.rkt"
"utils.ss"
"const.ss"
"types.ss"
"window.rkt"
"wndclass.rkt")
(provide frame%)
(define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL))
(defclass frame% window%
(init parent
label
x y w h
style)
(inherit get-win32
is-shown?
get-eventspace)
(super-new [parent #f]
[win32
(CreateWindowExW (bitwise-ior WS_EX_LAYERED)
"PLTFrame"
(if label label "")
WS_OVERLAPPEDWINDOW
0 0 w h
#f
#f
hInstance
#f)]
[style (cons 'invisible style)])
(define win32 (get-win32))
(SetLayeredWindowAttributes win32 0 255 LWA_ALPHA)
(define/public (is-dialog?) #f)
(define/override (show on?)
(let ([es (get-eventspace)])
(when (and on?
(eventspace-shutdown? es))
(error (string->symbol
(format "show method in ~a"
(if (is-dialog?)
'dialog%
'frame%)))
"eventspace has been shutdown")))
(super show on?))
(define/override (direct-show on?)
(register-frame-shown this on?)
(super direct-show on?))
(define/override (wndproc w msg wparam lparam)
(cond
[(= msg WM_CLOSE)
(queue-window-event this (lambda ()
(when (on-close)
(direct-show #f))))
0]
[else (super wndproc w msg wparam lparam)]))
(define/public (on-close) (void))
(define/override (is-shown-to-root?)
(is-shown?))
(define/override (is-enabled-to-root?)
#t)
(define/override (get-x)
(RECT-left (GetWindowRect win32)))
(define/override (get-y)
(RECT-top (GetWindowRect win32)))
(def/public-unimplemented on-toolbar-click)
(def/public-unimplemented on-menu-click)
(def/public-unimplemented on-menu-command)
(def/public-unimplemented on-mdi-activate)
(def/public-unimplemented enforce-size)
(def/public-unimplemented on-close)
(define/public (enforce-size min-x min-y max-x max-y step-x step-y)
(void))
(def/public-unimplemented on-activate)
(def/public-unimplemented designate-root-frame)
(def/public-unimplemented system-menu)
@ -23,5 +96,4 @@
(def/public-unimplemented set-menu-bar)
(def/public-unimplemented set-icon)
(def/public-unimplemented iconize)
(def/public-unimplemented set-title)
(super-new))
(def/public-unimplemented set-title))

13
collects/mred/private/wx/win32/icons.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket/base
(require ffi/unsafe)
(provide IDC_ARROW IDC_CROSS
IDI_APPLICATION IDI_HAND IDI_QUESTION IDI_WINLOGO)
(define (MAKEINTRESOURCE n) (ptr-add #f n))
(define IDC_ARROW (MAKEINTRESOURCE 32512))
(define IDC_CROSS (MAKEINTRESOURCE 32515))
(define IDI_APPLICATION (MAKEINTRESOURCE 32512))
(define IDI_HAND (MAKEINTRESOURCE 32513))
(define IDI_QUESTION (MAKEINTRESOURCE 32514))
(define IDI_WINLOGO (MAKEINTRESOURCE 32517))

7
collects/mred/private/wx/win32/init.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
;; Registers the window class:
(require "wndclass.rkt"
"queue.rkt")
(define pump-thread (win32-start-event-pump))

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

@ -1,16 +1,35 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt"
"window.rkt")
"window.rkt"
"wndclass.rkt"
"const.rkt")
(provide panel%)
(defclass panel% window%
(init parent
x y w h
style
label)
(super-new [parent parent]
[win32
(CreateWindowExW 0
"PLTPanel"
#f
(bitwise-ior WS_CHILD)
0 0 w h
(send parent get-win32)
#f
hInstance
#f)]
[style style])
(def/public-unimplemented get-label-position)
(def/public-unimplemented set-label-position)
(def/public-unimplemented on-char)
(def/public-unimplemented on-event)
(def/public-unimplemented on-paint)
(def/public-unimplemented set-item-cursor)
(def/public-unimplemented get-item-cursor)
(super-new))
(define/public (set-item-cursor x y) (void))
(def/public-unimplemented get-item-cursor))

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

@ -1,5 +1,6 @@
#lang scheme/base
(require "button.rkt"
(require "init.rkt"
"button.rkt"
"canvas.rkt"
"check-box.rkt"
"choice.rkt"

30
collects/mred/private/wx/win32/procs.rkt
View File

@ -1,5 +1,7 @@
#lang scheme/base
(require "../../syntax.rkt")
#lang racket/base
(require racket/class
"../../syntax.rkt"
racket/draw)
(provide
special-control-key
@ -44,25 +46,29 @@
(define-unimplemented special-option-key)
(define-unimplemented get-color-from-user)
(define-unimplemented get-font-from-user)
(define-unimplemented get-panel-background)
(define (get-panel-background) (make-object color% "gray"))
(define-unimplemented play-sound)
(define-unimplemented find-graphical-system-path)
(define-unimplemented register-collecting-blit)
(define-unimplemented unregister-collecting-blit)
(define-unimplemented shortcut-visible-in-label?)
(define (shortcut-visible-in-label? ?) #t)
(define-unimplemented location->window)
(define-unimplemented send-event)
(define-unimplemented file-creator-and-type)
(define-unimplemented run-printout)
(define-unimplemented get-double-click-time)
(define-unimplemented get-control-font-size)
(define (get-double-click-time) 500)
(define (get-control-font-size) 10)
(define-unimplemented cancel-quit)
(define-unimplemented fill-private-color)
(define-unimplemented flush-display)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define-unimplemented display-origin)
(define-unimplemented display-size)
(define (display-origin xb yb ?)
(set-box! xb 0)
(set-box! yb 0))
(define (display-size xb yb ?)
(set-box! xb 1024)
(set-box! yb 768))
(define-unimplemented bell)
(define-unimplemented hide-cursor)
(define-unimplemented end-busy-cursor)
@ -76,8 +82,12 @@
(define-unimplemented get-the-clipboard)
(define-unimplemented show-print-setup)
(define-unimplemented can-show-print-setup?)
(define-unimplemented get-highlight-background-color)
(define-unimplemented get-highlight-text-color)
(define (get-highlight-background-color)
(make-object color% 0 0 0))
(define (get-highlight-text-color)
(make-object color% 255 255 255))
(define-unimplemented make-screen-bitmap)
(define (check-for-break) #f)

62
collects/mred/private/wx/win32/queue.rkt Normal file
View File

@ -0,0 +1,62 @@
#lang racket/base
(require ffi/unsafe
"utils.rkt"
"types.rkt"
"const.rkt"
"../../lock.rkt"
"../common/queue.rkt")
(provide win32-start-event-pump
;; from common/queue:
current-eventspace
queue-event
yield)
;; ------------------------------------------------------------
;; Win32 event pump
(define _LPMSG _pointer)
(define-cstruct _MSG ([hwnd _HWND]
[message _UINT]
[wParam _WPARAM]
[lParam _LPARAM]
[time _DWORD]
[pt _POINT]))
(define-user32 GetQueueStatus (_wfun _UINT -> _DWORD))
(define-user32 GetMessageW (_wfun _LPMSG _HWND _UINT _UINT -> _BOOL))
(define-user32 PeekMessageW (_wfun _LPMSG _HWND _UINT _UINT _UINT -> _BOOL))
(define-user32 TranslateMessage (_wfun _LPMSG -> _BOOL))
(define-user32 DispatchMessageW (_wfun _LPMSG -> _LRESULT))
(define-user32 PostQuitMessage (_wfun _int -> _void))
(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void))
(define msg (malloc _MSG 'raw))
(define (events-ready?)
(GetQueueStatus QS_ALLINPUT))
(define (install-wakeup fds)
(pre-event-sync #t)
(scheme_add_fd_eventmask fds QS_ALLINPUT))
(set-check-queue! events-ready?)
(set-queue-wakeup! install-wakeup)
(define (dispatch-all-ready)
(pre-event-sync #f)
(let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)])
(when v
(TranslateMessage msg)
(DispatchMessageW msg)
(dispatch-all-ready))))
(define (win32-start-event-pump)
(thread (lambda ()
(let loop ()
(sync queue-evt)
(as-entry dispatch-all-ready)
(loop)))))

83
collects/mred/private/wx/win32/types.rkt Normal file
View File

@ -0,0 +1,83 @@
#lang racket/base
(require ffi/unsafe)
(provide _wfun
_DWORD
_ATOM
_WPARAM
_LPARAM
_LRESULT
_BOOL
_UINT
_BYTE
_LONG
_HINSTANCE
_HWND
_HMENU
_HICON
_HCURSOR
_HBRUSH
_HDC
_COLORREF
_fnpointer
_permanent-string/utf-16
(struct-out POINT) _POINT _POINT-pointer
(struct-out RECT) _RECT _RECT-pointer)
(define-syntax-rule (_wfun . a)
(_fun #:abi 'stdcall . a))
(define _DWORD _int32)
(define _ATOM _int)
(define _WPARAM _long)
(define _LPARAM _long)
(define _LRESULT _long)
(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v)))))
(define _UINT _uint)
(define _BYTE _uint8)
(define _HINSTANCE (_cpointer/null 'HINSTANCE))
(define _HWND (_cpointer/null 'HWND))
(define _HMENU (_cpointer/null 'HMENU))
(define _HICON (_cpointer/null 'HICON))
(define _HCURSOR (_cpointer/null 'HCURSOR))
(define _HBRUSH (_cpointer/null 'HBRUSH))
(define _HDC (_cpointer/null 'HDC))
(define _COLORREF _DWORD)
(define _fnpointer (_or-null _fpointer))
(define _permanent-string/utf-16
(make-ctype _pointer
(lambda (s)
(and s
(let ([v (malloc _gcpointer)])
(ptr-set! v _string/utf-16 s)
(let ([p (ptr-ref v _gcpointer)])
(let ([len (let loop ([i 0])
(if (zero? (ptr-ref p _uint16 i))
(add1 i)
(loop (add1 i))))])
(let ([c (malloc len _uint16 'raw)])
(memcpy c p len _uint16)
c))))))
(lambda (p)
(and p
(cast p _pointer _string/utf-16)))))
(define _LONG _long)
(define-cstruct _POINT ([x _LONG]
[y _LONG]))
(define-cstruct _RECT ([left _LONG]
[top _LONG]
[right _LONG]
[bottom _LONG]))

17
collects/mred/private/wx/win32/utils.rkt Normal file
View File

@ -0,0 +1,17 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
"../common/utils.rkt")
(provide define-user32
define-kernel32
define-comctl32
define-mz)
(define user32-lib (ffi-lib "user32.dll"))
(define kernel32-lib (ffi-lib "kernel32.dll"))
(define comctl32-lib (ffi-lib "comctl32.dll"))
(define-ffi-definer define-user32 user32-lib)
(define-ffi-definer define-kernel32 kernel32-lib)
(define-ffi-definer define-comctl32 comctl32-lib)

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

@ -1,10 +1,69 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt")
#lang racket/base
(require ffi/unsafe
racket/class
racket/draw
"../../syntax.rkt"
"utils.rkt"
"types.rkt"
"wndclass.rkt"
"queue.rkt")
(provide window%)
(provide window%
queue-window-event
CreateWindowExW
GetWindowRect)
(define-user32 CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
_DWORD
_int _int _int _int
_HWND _HMENU _HINSTANCE _pointer
-> _HWND))
(define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r))
(define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r))
(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL))
(define-user32 ShowWindow (_wfun _HWND _int -> _BOOL))
(define SW_SHOW 5)
(define SW_HIDE 0)
(define-user32 GetDialogBaseUnits (_fun -> _LONG))
(define measure-dc #f)
(define-values (dlu-x dlu-y)
(let ([v (GetDialogBaseUnits)])
(values (* 1/4 (bitwise-and v #xFF))
(* 1/8 (arithmetic-shift v -16)))))
(defclass window% object%
(init-field parent win32)
(init style)
(super-new)
(define eventspace (current-eventspace))
(set-win32-wx! win32 this)
(unless (memq 'invisible style)
(show #t))
(define/public (get-win32) win32)
(define/public (get-client-win32) win32)
(define/public (get-eventspace) eventspace)
(define/public (wndproc w msg wparam lparam)
(DefWindowProcW w msg wparam lparam))
(define/public (show on?)
(direct-show on?))
(define/public (direct-show on?)
(void (ShowWindow win32 (if on? SW_SHOW SW_HIDE))))
(def/public-unimplemented on-drop-file)
(def/public-unimplemented pre-on-event)
(def/public-unimplemented pre-on-char)
@ -12,31 +71,92 @@
(def/public-unimplemented on-set-focus)
(def/public-unimplemented on-kill-focus)
(def/public-unimplemented get-handle)
(def/public-unimplemented is-enabled-to-root?)
(def/public-unimplemented is-shown-to-root?)
(define/public (is-window-enabled?)
#t)
(define/public (is-enabled-to-root?)
(and (is-window-enabled?)
(send parent is-enabled-to-root?)))
(define/public (is-shown-to-root?)
(and (is-shown?)
(send parent is-shown-to-root?)))
(define/public (is-shown?)
#t)
(def/public-unimplemented set-phantom-size)
(def/public-unimplemented get-y)
(def/public-unimplemented get-x)
(def/public-unimplemented get-width)
(def/public-unimplemented get-height)
(define/public (get-x)
(let ([r (GetWindowRect win32)])
(- (RECT-left r) (send parent get-x))))
(define/public (get-y)
(let ([r (GetWindowRect win32)])
(- (RECT-top r) (send parent get-y))))
(define/public (get-width)
(let ([r (GetWindowRect win32)])
(- (RECT-right r) (RECT-left r))))
(define/public (get-height)
(let ([r (GetWindowRect win32)])
(- (RECT-bottom r) (RECT-top r))))
(define/public (set-size x y w h)
(void
(if (or (= x -11111)
(= y -11111)
(= w -1)
(= h -1))
(let ([r (GetWindowRect win32)])
(MoveWindow win32
(if (= x -11111) (RECT-left r) x)
(if (= y -11111) (RECT-right r) y)
(if (= w -1) (- (RECT-right r) (RECT-left r)) w)
(if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)
#t))
(MoveWindow win32 x y w h #t))))
(define/public (move x y)
(set-size x y -1 -1))
(define/public (auto-size label min-w min-h)
(unless measure-dc
(let* ([bm (make-object bitmap% 1 1)]
[dc (make-object bitmap-dc% bm)]
[font (make-object font% 8 'system)])
(send dc set-font font)
(set! measure-dc dc)))
(let-values ([(w h d a) (send measure-dc get-text-extent label #f #t)]
[(->int) (lambda (v) (inexact->exact (floor v)))])
(set-size -11111 -11111
(max (->int w) (->int (* dlu-x min-w)))
(max (->int h) (->int (* dlu-y min-h))))))
(def/public-unimplemented popup-menu)
(def/public-unimplemented center)
(def/public-unimplemented get-parent)
(define/public (get-parent) parent)
(def/public-unimplemented refresh)
(def/public-unimplemented screen-to-client)
(def/public-unimplemented client-to-screen)
(def/public-unimplemented drag-accept-files)
(def/public-unimplemented enable)
(def/public-unimplemented get-position)
(def/public-unimplemented get-client-size)
(define/public (get-client-size w h)
(let ([r (GetClientRect (get-client-win32))])
(set-box! w (- (RECT-right r) (RECT-left r)))
(set-box! h (- (RECT-bottom r) (RECT-top r)))))
(def/public-unimplemented get-size)
(def/public-unimplemented fit)
(def/public-unimplemented is-shown?)
(def/public-unimplemented show)
(def/public-unimplemented set-cursor)
(def/public-unimplemented move)
(def/public-unimplemented set-size)
(def/public-unimplemented set-focus)
(def/public-unimplemented gets-focus?)
(def/public-unimplemented centre)
(super-new))
(def/public-unimplemented centre))
;; ----------------------------------------
(define (queue-window-event win thunk)
(queue-event (send win get-eventspace) thunk))

112
collects/mred/private/wx/win32/wndclass.rkt Normal file
View File

@ -0,0 +1,112 @@
#lang racket/base
(require ffi/unsafe
racket/class
"utils.rkt"
"types.rkt"
"const.rkt"
"icons.rkt")
(provide hInstance
DefWindowProcW
win32->wx
set-win32-wx!
MessageBoxW)
;; ----------------------------------------
(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))
(define (win32->wx win32)
(let ([p (GetWindowLongW win32 GWLP_USERDATA)])
(and p (ptr-ref p _racket))))
(define (set-win32-wx! win32 wx)
(SetWindowLongW win32 GWLP_USERDATA (malloc-immobile-cell wx)))
;; ----------------------------------------
(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-cstruct _WNDCLASS ([style _UINT]
[lpfnWndProc _WndProc]
[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 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR))
(define-user32 LoadIconW (_wfun _HINSTANCE _pointer -> _HICON))
(define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
#;(define-user32 PostQuitMessage (_wfun _int -> _void))
(define (wind-proc w msg wparam lparam)
(let ([wx (win32->wx w)])
(if wx
(send wx wndproc w msg wparam lparam)
(DefWindowProcW w msg wparam lparam))))
(define hInstance (GetModuleHandleW #f))
(void (RegisterClassW (make-WNDCLASS CS_OWNDC
wind-proc
0
0
hInstance
(LoadIconW #f IDI_APPLICATION)
(LoadCursorW #f IDC_ARROW)
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
(cpointer-push-tag! p 'HBRUSH)
p)
#f ; menu
"PLTFrame")))
(void (RegisterClassW (make-WNDCLASS 0 ; not CS_OWNDC !
wind-proc
0
0
hInstance
#f
(LoadCursorW #f IDC_ARROW)
(let ([p (ptr-add #f (+ COLOR_WINDOW 1))])
(cpointer-push-tag! p 'HBRUSH)
p)
#f ; menu
"PLTCanvas")))
(void (RegisterClassW (make-WNDCLASS 0
wind-proc
0
0
hInstance
#f
(LoadCursorW #f IDC_ARROW)
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
(cpointer-push-tag! p 'HBRUSH)
p)
#f ; menu
"PLTPanel")))
(define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int))