dx9d3d-0.1: DirectX9/D3D/Utility/Init.hs

module DirectX9.D3D.Utility.Init
where
import Graphics.Win32   ( WindowClosure, HWND, mkClassName, loadIcon
                        , loadCursor, createSolidBrush, rgb, registerClass
                        , showWindow, updateWindow, sendMessage, WPARAM
                        , LPARAM, LRESULT, WindowMessage, defWindowProc
                        , createWindow, getMessage, translateMessage
                        , dispatchMessage, allocaMessage
                        , iDI_APPLICATION, iDC_ARROW, cS_VREDRAW, cS_HREDRAW
                        , wS_OVERLAPPEDWINDOW, sW_SHOWNORMAL, wM_DESTROY
                        , wM_QUIT, wM_KEYDOWN, vK_ESCAPE )
import System.Win32.DLL ( getModuleHandle )
import Control.Concurrent   ( newEmptyMVar, putMVar, takeMVar, tryTakeMVar, forkIO )
-- import Control.Exception ( catch )
-- import Prelude hiding ( catch )

makeWindow :: Int -> Int -> String -> WindowClosure -> IO HWND
makeWindow width height name proc = do
    let winClass = mkClassName name
    icon         <- loadIcon   Nothing iDI_APPLICATION
    cursor       <- loadCursor Nothing iDC_ARROW
    bgBrush      <- createSolidBrush (rgb 0 0 255)
    instanc <- getModuleHandle Nothing
    let wclass = ( cS_VREDRAW + cS_HREDRAW, instanc, Just icon, Just cursor
                 , Just bgBrush, Nothing, winClass )
    registerClass wclass
    w <- createWindow
            winClass name
            wS_OVERLAPPEDWINDOW
            Nothing Nothing
            (Just width) (Just height)
            Nothing Nothing
            instanc proc
    showWindow w sW_SHOWNORMAL
    updateWindow w
    return w


basicWindowProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT
basicWindowProc hwnd wmsg wParam lParam
    | wmsg==wM_DESTROY = do
        sendMessage hwnd wM_QUIT 1 0
        return 0
    | wmsg==wM_KEYDOWN && wParam==vK_ESCAPE =  do
        sendMessage hwnd wM_QUIT 1 0
        return 0    
    | otherwise =
        defWindowProc (Just hwnd) wmsg wParam lParam

messageAndRenderLoop :: HWND -> (Integer -> IO a) -> IO ()
messageAndRenderLoop hwnd proc = do
    signal  <- newEmptyMVar
    quit    <- newEmptyMVar
    forkIO $ catch
        (render signal quit 1)
        (\e -> do
            print e
            putMVar quit ())
    loop signal quit
    where
        -- todo: exceptions
        render signal quit frame = do
            proc frame
            s <- tryTakeMVar signal
            case s of
                Nothing -> render signal quit (frame+1)
                Just _  -> putMVar quit ()
        loop signal quit =  do
            more <- allocaMessage $ \msg ->
                catch
                    (do
                        more <- getMessage msg (Just hwnd)
                        translateMessage msg
                        dispatchMessage msg
                        return more)
                    (const $ return False)
            if more
                then loop signal quit
                else do
                    putMVar signal ()
                    takeMVar quit