105 lines
3.1 KiB
Haskell
105 lines
3.1 KiB
Haskell
|
-- Haskell version of "Hello, World" using the Win32 library.
|
||
|
|
-- Demonstrates how the Win32 library can be put to use.
|
||
|
|
-- (c) sof 1999
|
||
|
|
|
||
|
|
|
||
|
|
module Main(main) where
|
||
|
|
|
||
|
|
import qualified Win32
|
||
|
|
import Addr
|
||
|
|
|
||
|
|
-- Toplevel main just creates a window and pumps messages.
|
||
|
|
-- The window procedure (wndProc) we pass in is partially
|
||
|
|
-- applied with the user action that takes care of responding
|
||
|
|
-- to repaint messages (WM_PAINT).
|
||
|
|
|
||
|
|
main :: IO ()
|
||
|
|
main = do
|
||
|
|
lpps <- Win32.malloc Win32.sizeofPAINTSTRUCT
|
||
|
|
hwnd <- createWindow 200 200 (wndProc lpps onPaint)
|
||
|
|
messagePump hwnd
|
||
|
|
|
||
|
|
-- OnPaint handler for a window - draw a string centred
|
||
|
|
-- inside it.
|
||
|
|
onPaint :: Win32.RECT -> Win32.HDC -> IO ()
|
||
|
|
onPaint (_,_,w,h) hdc = do
|
||
|
|
Win32.setBkMode hdc Win32.tRANSPARENT
|
||
|
|
Win32.setTextColor hdc (Win32.rgb 255 255 0)
|
||
|
|
let y | h==10 = 0
|
||
|
|
| otherwise = ((h-10) `div` 2)
|
||
|
|
x | w==50 = 0
|
||
|
|
| otherwise = (w-50) `div` 2
|
||
|
|
Win32.textOut hdc x y "Hello, world"
|
||
|
|
return ()
|
||
|
|
|
||
|
|
-- Simple window procedure - one way to improve and generalise
|
||
|
|
-- it would be to pass it a message map (represented as a
|
||
|
|
-- finite map from WindowMessages to actions, perhaps).
|
||
|
|
|
||
|
|
wndProc :: Win32.LPPAINTSTRUCT
|
||
|
|
-> (Win32.RECT -> Win32.HDC -> IO ()) -- on paint action
|
||
|
|
-> Win32.HWND
|
||
|
|
-> Win32.WindowMessage
|
||
|
|
-> Win32.WPARAM
|
||
|
|
-> Win32.LPARAM
|
||
|
|
-> IO Win32.LRESULT
|
||
|
|
wndProc lpps onPaint hwnd wmsg wParam lParam
|
||
|
|
| wmsg == Win32.wM_DESTROY = do
|
||
|
|
Win32.sendMessage hwnd Win32.wM_QUIT 1 0
|
||
|
|
return 0
|
||
|
|
| wmsg == Win32.wM_PAINT && hwnd /= nullAddr = do
|
||
|
|
r <- Win32.getClientRect hwnd
|
||
|
|
paintWith lpps hwnd (onPaint r)
|
||
|
|
return 0
|
||
|
|
| otherwise =
|
||
|
|
Win32.defWindowProc (Just hwnd) wmsg wParam lParam
|
||
|
|
|
||
|
|
createWindow :: Int -> Int -> Win32.WindowClosure -> IO Win32.HWND
|
||
|
|
createWindow width height wndProc = do
|
||
|
|
let winClass = Win32.mkClassName "Hello"
|
||
|
|
icon <- Win32.loadIcon Nothing Win32.iDI_APPLICATION
|
||
|
|
cursor <- Win32.loadCursor Nothing Win32.iDC_ARROW
|
||
|
|
bgBrush <- Win32.createSolidBrush (Win32.rgb 0 0 255)
|
||
|
|
mainInstance <- Win32.getModuleHandle Nothing
|
||
|
|
Win32.registerClass
|
||
|
|
( Win32.cS_VREDRAW + Win32.cS_HREDRAW
|
||
|
|
, mainInstance
|
||
|
|
, Just icon
|
||
|
|
, Just cursor
|
||
|
|
, Just bgBrush
|
||
|
|
, Nothing
|
||
|
|
, winClass
|
||
|
|
)
|
||
|
|
w <- Win32.createWindow
|
||
|
|
winClass
|
||
|
|
"Hello, World example"
|
||
|
|
Win32.wS_OVERLAPPEDWINDOW
|
||
|
|
Nothing Nothing -- leave it to the shell to decide the position
|
||
|
|
-- at where to put the window initially
|
||
|
|
(Just width)
|
||
|
|
(Just height)
|
||
|
|
Nothing -- no parent, i.e, root window is the parent.
|
||
|
|
Nothing -- no menu handle
|
||
|
|
mainInstance
|
||
|
|
wndProc
|
||
|
|
Win32.showWindow w Win32.sW_SHOWNORMAL
|
||
|
|
Win32.updateWindow w
|
||
|
|
return w
|
||
|
|
|
||
|
|
messagePump :: Win32.HWND -> IO ()
|
||
|
|
messagePump hwnd = do
|
||
|
|
msg <- Win32.getMessage (Just hwnd) `catch` \ _ -> return nullAddr
|
||
|
|
if msg == nullAddr then
|
||
|
|
return ()
|
||
|
|
else do
|
||
|
|
Win32.translateMessage msg
|
||
|
|
Win32.dispatchMessage msg
|
||
|
|
messagePump hwnd
|
||
|
|
|
||
|
|
paintWith :: Win32.LPPAINTSTRUCT -> Win32.HWND -> (Win32.HDC -> IO a) -> IO a
|
||
|
|
paintWith lpps hwnd p = do
|
||
|
|
hdc <- Win32.beginPaint hwnd lpps
|
||
|
|
a <- p hdc
|
||
|
|
Win32.endPaint hwnd lpps
|
||
|
|
return a
|