dx9base-0.1: DirectX9/ComObject.hs

{-#  LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses #-}
module DirectX9.ComObject
where
import Control.Exception    ( bracket_ )
import Foreign.Concurrent   ( addForeignPtrFinalizer )
import Foreign          ( Ptr, poke, peek , castPtr, ForeignPtr, withForeignPtr
                        , nullPtr, mallocForeignPtr )
import System.Win32     ( UINT )


---------------------------------------------------------------------------
-- ComObject

newtype ComObject a = ComObject (ForeignPtr (Ptr a))

comMake :: Ptr a -> IO (ComObject a)
comMake ptr = do
    fp <- mallocForeignPtr
    ptr' <- withForeignPtr fp $ \ptr' ->do
        poke ptr' ptr
        return ptr'
    addForeignPtrFinalizer fp (fin ptr')
    return $ ComObject fp
    where
        fin ptr' = do
            ptr <- peek ptr'
            if ptr==nullPtr
                then return ()
                else c_Release (castPtr ptr) >> return ()

comUnManage :: ComObject a -> IO (Ptr a)
comUnManage obj = withCom obj $ \ptr -> do
    c_AddRef (castPtr ptr)
    return ptr

comFree :: ComObject a -> IO Int
comFree (ComObject o) = withForeignPtr o $ \ptr -> do
    ptr' <- peek ptr
    if ptr'==nullPtr
        then return (-1)
        else do
            c <- c_Release (castPtr ptr')
            poke ptr nullPtr
            return $ fromIntegral c

withCom :: ComObject a -> (Ptr a -> IO b) -> IO b
withCom (ComObject obj) act = withForeignPtr obj $ \ptr -> do
    ptr' <- peek ptr
    if ptr'==nullPtr
        then act ptr'
        else bracket_
            (c_AddRef $ castPtr ptr')
            (c_Release $ castPtr ptr')
            (act ptr')

class ComCast base derived where
    comCast :: ComObject derived -> IO (Maybe (ComObject base))
    withCastedCom :: ComObject derived -> (Ptr base -> IO a) -> IO a
    
    comCast (ComObject obj) = withForeignPtr obj $ \ptr -> do
        ptr' <- peek ptr
        if ptr'==nullPtr
            then return Nothing
            else do
                c_AddRef (castPtr ptr')
                comMake (castPtr ptr') >>= return.Just
    withCastedCom obj act = withCom obj (act.castPtr)
        

foreign import ccall unsafe "fake.h AddRef"
    c_AddRef :: Ptr () -> IO UINT
foreign import ccall unsafe "fake.h Release"
    c_Release :: Ptr () -> IO UINT