1-- Haskell version of "Hello, World" using the Win32 library.
2-- Demonstrates how the Win32 library can be put to use.
3-- (c) sof 1999
4
5
6module Main(main) where
7
8import qualified Win32
9import Addr
10
11-- Toplevel main just creates a window and pumps messages.
12-- The window procedure (wndProc) we pass in is partially
13-- applied with the user action that takes care of responding
14-- to repaint messages (WM_PAINT).
15
16main :: IO ()
17main = do
18  lpps <- Win32.malloc Win32.sizeofPAINTSTRUCT
19  hwnd <- createWindow 200 200 (wndProc lpps onPaint)
20  messagePump hwnd
21
22-- OnPaint handler for a window - draw a string centred
23-- inside it.
24onPaint :: Win32.RECT -> Win32.HDC -> IO ()
25onPaint (_,_,w,h) hdc = do
26   Win32.setBkMode hdc Win32.tRANSPARENT
27   Win32.setTextColor hdc (Win32.rgb 255 255 0)
28   let y | h==10     = 0
29         | otherwise = ((h-10) `div` 2)
30       x | w==50     = 0
31         | otherwise = (w-50) `div` 2
32   Win32.textOut hdc x y "Hello, world"
33   return ()
34
35-- Simple window procedure - one way to improve and generalise
36-- it would be to pass it a message map (represented as a
37-- finite map from WindowMessages to actions, perhaps).
38
39wndProc :: Win32.LPPAINTSTRUCT
40        -> (Win32.RECT -> Win32.HDC -> IO ()) -- on paint action
41        -> Win32.HWND
42        -> Win32.WindowMessage
43        -> Win32.WPARAM
44        -> Win32.LPARAM
45        -> IO Win32.LRESULT
46wndProc lpps onPaint hwnd wmsg wParam lParam
47 | wmsg == Win32.wM_DESTROY = do
48     Win32.sendMessage hwnd Win32.wM_QUIT 1 0
49     return 0
50 | wmsg == Win32.wM_PAINT && hwnd /= nullAddr = do
51     r <- Win32.getClientRect hwnd
52     paintWith lpps hwnd (onPaint r)
53     return 0
54 | otherwise =
55     Win32.defWindowProc (Just hwnd) wmsg wParam lParam
56
57createWindow :: Int -> Int -> Win32.WindowClosure -> IO Win32.HWND
58createWindow width height wndProc = do
59  let winClass = Win32.mkClassName "Hello"
60  icon         <- Win32.loadIcon   Nothing Win32.iDI_APPLICATION
61  cursor       <- Win32.loadCursor Nothing Win32.iDC_ARROW
62  bgBrush      <- Win32.createSolidBrush (Win32.rgb 0 0 255)
63  mainInstance <- Win32.getModuleHandle Nothing
64  Win32.registerClass
65          ( Win32.cS_VREDRAW + Win32.cS_HREDRAW
66          , mainInstance
67          , Just icon
68          , Just cursor
69          , Just bgBrush
70          , Nothing
71          , winClass
72          )
73  w <- Win32.createWindow
74                 winClass
75                 "Hello, World example"
76                 Win32.wS_OVERLAPPEDWINDOW
77                 Nothing Nothing -- leave it to the shell to decide the position
78                                 -- at where to put the window initially
79                 (Just width)
80                 (Just height)
81                 Nothing      -- no parent, i.e, root window is the parent.
82                 Nothing      -- no menu handle
83                 mainInstance
84                 wndProc
85  Win32.showWindow w Win32.sW_SHOWNORMAL
86  Win32.updateWindow w
87  return w
88
89messagePump :: Win32.HWND -> IO ()
90messagePump hwnd = do
91  msg  <- Win32.getMessage (Just hwnd) `catch` \ _ -> return nullAddr
92  if msg == nullAddr then
93    return ()
94   else do
95    Win32.translateMessage msg
96    Win32.dispatchMessage msg
97    messagePump hwnd
98
99paintWith :: Win32.LPPAINTSTRUCT -> Win32.HWND -> (Win32.HDC -> IO a) -> IO a
100paintWith lpps hwnd p = do
101  hdc  <- Win32.beginPaint hwnd lpps
102  a    <- p hdc
103  Win32.endPaint hwnd lpps
104  return a
105