module Data.GI.Base.GObject
( constructGObject
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Proxy (Proxy(..))
import Foreign.C (CUInt(..), CString, newCString)
import Foreign
import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy,
attrConstruct)
import Data.GI.Base.BasicTypes (GType(..), GObject(..))
import Data.GI.Base.GValue (GValue(..))
import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject)
import Data.GI.Base.Overloading (ResolveAttribute)
foreign import ccall "dbg_g_object_newv" g_object_newv ::
GType -> CUInt -> Ptr a -> IO (Ptr b)
constructGObject :: forall o m. (GObject o, MonadIO m)
=> (ForeignPtr o -> o)
-> [AttrOp o 'AttrConstruct]
-> m o
constructGObject constructor attrs = liftIO $ do
props <- mapM construct attrs
let nprops = length props
params <- mallocBytes (nprops*gparameterSize)
fill params props
gtype <- gobjectType (undefined :: o)
result <- g_object_newv gtype (fromIntegral nprops) params
freeStrings nprops params
free params
mapM_ (touchManagedPtr . snd) props
wrapObject constructor (result :: Ptr o)
where
resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve _ = Proxy
construct :: AttrOp o 'AttrConstruct ->
IO (String, GValue)
construct (attr := x) = attrConstruct (resolve attr) x
construct (attr :=> x) = x >>= attrConstruct (resolve attr)
gvalueSize = (24)
gparameterSize = (32)
fill :: Ptr () -> [(String, GValue)] -> IO ()
fill _ [] = return ()
fill dataPtr ((str, gvalue):xs) =
do cstr <- newCString str
poke (castPtr dataPtr) cstr
withManagedPtr gvalue $ \gvalueptr ->
copyBytes (dataPtr `plusPtr` sizeOf nullPtr) gvalueptr gvalueSize
fill (dataPtr `plusPtr` gparameterSize) xs
freeStrings :: Int -> Ptr () -> IO ()
freeStrings 0 _ = return ()
freeStrings n dataPtr =
do cstr <- peek (castPtr dataPtr) :: IO CString
free cstr
freeStrings (n1) (dataPtr `plusPtr` gparameterSize)