module Data.GI.Base.GObject
( constructGObject
, new'
) 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(..), ManagedPtr)
import Data.GI.Base.GValue (GValue(..), GValueConstruct(..))
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)
=> (ManagedPtr o -> o)
-> [AttrOp o 'AttrConstruct]
-> m o
constructGObject constructor attrs = liftIO $ do
props <- mapM construct attrs
doConstructGObject constructor props
where
resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)
resolve _ = Proxy
construct :: AttrOp o 'AttrConstruct ->
IO (GValueConstruct o)
construct (attr := x) = attrConstruct (resolve attr) x
construct (attr :=> x) = x >>= attrConstruct (resolve attr)
doConstructGObject :: forall o m. (GObject o, MonadIO m)
=> (ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject constructor props = liftIO $ do
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 . deconstructGValue) props
wrapObject constructor (result :: Ptr o)
where
deconstructGValue :: GValueConstruct o -> GValue
deconstructGValue (GValueConstruct _ v) = v
gvalueSize = (24)
gparameterSize = (32)
fill :: Ptr () -> [GValueConstruct o] -> IO ()
fill _ [] = return ()
fill dataPtr ((GValueConstruct 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)
new' :: (MonadIO m, GObject o) =>
(ManagedPtr o -> o) -> [IO (GValueConstruct o)] -> m o
new' constructor actions = do
props <- liftIO $ sequence (actions)
doConstructGObject constructor props