dx9d3dx-0.1.1: DirectX9/D3D/X/Shader.hs

{-#  LANGUAGE ForeignFunctionInterface #-}
module DirectX9.D3D.X.Shader
where
import DirectX9.Error
import DirectX9.D3D
import DirectX9.D3D.X.Raw
import DirectX9.D3D.X.Misc

import Control.Exception    ( bracket )
import Foreign          ( nullPtr, withArray0, with, FunPtr, allocaBytes
                        , pokeByteOff, poke, freeHaskellFunPtr, castPtr
                        , peekArray )
import Foreign.C.String ( withCString, withCStringLen, peekCAString )


type ShaderCode = [DWORD]
type Macros = [(String,String)]
type Includes = [([(Bool,String)],String)]
type ConstantTable = ComObject ID3DXConstantTable

d3dxWithMacros :: Macros -> (Ptr D3DXMACRO -> IO a) -> IO a
d3dxWithMacros m act = withMacros' [] m
    where
        nullMacro = D3DXMACRO nullPtr nullPtr
        withMacros' res ms = case ms of
            []      -> withArray0 nullMacro res act
            (n,v):y -> withCString n
                $ \n -> withCString v
                $ \v -> withMacros' ((D3DXMACRO n v):res) y
            
type ID3DXInclude_Open = Ptr () -> DWORD -> LPCSTR -> Ptr () -> Ptr (Ptr ()) -> Ptr UINT -> IO HRESULT
type ID3DXInclude_Close = Ptr () -> Ptr () -> IO HRESULT

d3dxWithIncludes :: Includes -> (Ptr ID3DXInclude -> IO b) -> IO b
d3dxWithIncludes  inc act = allocaBytes 8
    $ \vtbl -> with vtbl
    $ \this -> makeInc [] inc
    $ \inc -> bracket
        (make inc vtbl)
        end
        (const $ act (castPtr this))
    where
        makeInc res inc act = case inc of
            []  -> act res
            (i,v):y -> withCStringLen v
                $ \v -> makeInc (res ++ map (\x -> (x,v)) i) y act
        make inc vtbl = do
            o <- mkID3DXInclude_Open (open inc)
            c <- mkID3DXInclude_Close close
            pokeByteOff vtbl 0 o
            pokeByteOff vtbl (sizeOf o) c
            return (o,c)
        end (o,c) = do
            freeHaskellFunPtr o
            freeHaskellFunPtr c
        open inc _ ty name _ out outs = do
            name' <- peekCAString name
            case lookup (ty==d3DXINC_LOCAL,name') inc of
                Just (buf,len)  -> do
                    poke out (castPtr buf)
                    poke outs (fromIntegral len)
                    return d3D_OK
                Nothing         ->  do
                    poke out nullPtr
                    return d3DXERR_INVALIDDATA
        close _ _ = do
            return d3D_OK


d3dxHandleShaderCompileResult :: String -> (Ptr LPD3DXBUFFER -> Ptr LPD3DXBUFFER -> IO HRESULT) -> IO (Either String ShaderCode)
d3dxHandleShaderCompileResult n act =
    with nullPtr $ \out ->
    with nullPtr $ \err -> do
        res <- act out err
        out' <- peek out >>= comMake
        err' <- peek err
        if err'==nullPtr
            then do
                hrFail n (return res)
                x <- withXBufferLen out' $ \len buf -> peekArray (div len $ sizeOf (undefined::DWORD)) buf
                return $ Right x
            else comMake err' >>= peekCAStringFromXBuffer >>= return.Left

d3dxHandleShaderCompileResult2
    :: String
    -> (Ptr LPD3DXBUFFER -> Ptr LPD3DXBUFFER -> Ptr LPD3DXCONSTANTTABLE -> IO HRESULT)
    -> IO (Either String (ConstantTable,ShaderCode))
d3dxHandleShaderCompileResult2 n act =
    with nullPtr $ \out ->
    with nullPtr $ \err ->
    with nullPtr $ \ctbl -> do
        res <- act out err ctbl
        out' <- peek out >>= comMake
        ctbl' <- peek ctbl >>= comMake
        err' <- peek err
        if err'==nullPtr
            then do
                hrFail n (return res)
                x <- withXBufferLen out' $ \len buf -> peekArray (div len $ sizeOf (undefined::DWORD)) buf
                return $ Right (ctbl',x)
            else comMake err' >>= peekCAStringFromXBuffer >>= return.Left
        

assembleShader :: Macros -> Includes -> DWORD -> String -> IO (Either String ShaderCode)
assembleShader macros includes flags content = d3dxWithMacros macros
    $ \macros   -> d3dxWithIncludes includes
    $ \includes -> withCStringLen content
    $ \(content,len) ->
        d3dxHandleShaderCompileResult
            "D3DXAssembleShader" $ c_D3DXAssembleShader
                content (fromIntegral len) macros includes flags

assembleShaderFromFile :: Macros -> Includes -> DWORD -> String -> IO (Either String ShaderCode)
assembleShaderFromFile macros includes flags content = d3dxWithMacros macros
    $ \macros   -> d3dxWithIncludes includes
    $ \includes -> withCString content
    $ \content ->
        d3dxHandleShaderCompileResult
            "D3DXAssembleShaderFromFile" $ c_D3DXAssembleShaderFromFile
                content macros includes flags

compileShader :: Macros -> Includes -> DWORD -> String -> String -> String -> IO (Either String (ConstantTable,ShaderCode))
compileShader macros includes flags profile function content =
    d3dxWithMacros macros   $ \macros ->
    d3dxWithIncludes includes $ \includes ->
    withCStringLen content  $ \(content, len) ->
    withCString profile     $ \profile ->
    withCString function    $ \function ->
        d3dxHandleShaderCompileResult2
            "D3DXCompileShader" $ c_D3DXCompileShader
                content (fromIntegral len) macros includes profile function flags

compileShaderFromFile :: Macros -> Includes -> DWORD -> String -> String -> String -> IO (Either String (ConstantTable,ShaderCode))
compileShaderFromFile macros includes flags profile function file =
    d3dxWithMacros macros   $ \macros ->
    d3dxWithIncludes includes $ \includes ->
    withCString file        $ \file ->
    withCString profile     $ \profile ->
    withCString function    $ \function ->
        d3dxHandleShaderCompileResult2
            "D3DXCompileShaderFromFile" $ c_D3DXCompileShaderFromFile
                file macros includes profile function flags

foreign import stdcall "fake.h D3DXAssembleShader"
    c_D3DXAssembleShader
        :: LPCSTR -> UINT -> Ptr D3DXMACRO -> LPD3DXINCLUDE -> DWORD
        -> Ptr LPD3DXBUFFER -> Ptr LPD3DXBUFFER -> IO HRESULT
foreign import stdcall "fake.h D3DXAssembleShaderFromFileA"
    c_D3DXAssembleShaderFromFile
        :: LPCSTR -> Ptr D3DXMACRO -> LPD3DXINCLUDE -> DWORD
        -> Ptr LPD3DXBUFFER -> Ptr LPD3DXBUFFER -> IO HRESULT
foreign import stdcall "fake.h D3DXCompileShader"
    c_D3DXCompileShader
        :: LPCSTR -> UINT -> Ptr D3DXMACRO -> LPD3DXINCLUDE -> LPCSTR
        -> LPCSTR -> DWORD  -> Ptr LPD3DXBUFFER -> Ptr LPD3DXBUFFER
        -> Ptr LPD3DXCONSTANTTABLE -> IO HRESULT
foreign import stdcall "fake.h D3DXCompileShaderFromFileA"
    c_D3DXCompileShaderFromFile
        :: LPCSTR -> Ptr D3DXMACRO -> LPD3DXINCLUDE -> LPCSTR
        -> LPCSTR -> DWORD  -> Ptr LPD3DXBUFFER -> Ptr LPD3DXBUFFER
        -> Ptr LPD3DXCONSTANTTABLE -> IO HRESULT



foreign import stdcall "wrapper"
    mkID3DXInclude_Open :: ID3DXInclude_Open -> IO (FunPtr ID3DXInclude_Open)
foreign import stdcall "wrapper"
    mkID3DXInclude_Close :: ID3DXInclude_Close -> IO (FunPtr ID3DXInclude_Close)