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