content: -- 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
  