{-# LINE 1 "Data/GI/Base/GObject.hsc" #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.GI.Base.GObject
(
constructGObject
, new'
, gobjectGetUserData
, gobjectSetUserData
, gobjectModifyUserData
, DerivedGObject(..)
, registerGType
, gobjectGetPrivateData
, gobjectSetPrivateData
, gobjectModifyPrivateData
, GObjectClass(..)
, gtypeFromClass
, gtypeFromInstance
, gobjectInstallProperty
, gobjectInstallCIntProperty
, gobjectInstallCStringProperty
, gobjectInstallGBooleanProperty
) where
import Data.Maybe (catMaybes)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Proxy (Proxy(..))
import Data.Coerce (coerce)
import Foreign.C (CUInt(..), CString, newCString)
import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr, nullFunPtr)
import Foreign.StablePtr (newStablePtr, deRefStablePtr,
castStablePtrToPtr, castPtrToStablePtr)
import Foreign.Storable (Storable(peek, poke, pokeByteOff, sizeOf))
import Foreign (mallocBytes, copyBytes, free)
{-# LINE 58 "Data/GI/Base/GObject.hsc" #-}
import Data.Text (Text)
import qualified Data.Text as T
import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy,
attrConstruct, attrTransfer,
AttrInfo(..))
import Data.GI.Base.BasicTypes (CGType, GType(..), GObject, GSList,
GDestroyNotify, ManagedPtr(..), GParamSpec(..),
TypedObject(glibType),
gtypeName, g_slist_free)
import Data.GI.Base.BasicConversions (withTextCString, cstringToText,
packGSList, mapGSList)
import Data.GI.Base.CallStack (HasCallStack, prettyCallStack)
import Data.GI.Base.GParamSpec (PropertyInfo(..),
gParamSpecValue,
CIntPropertyInfo(..), CStringPropertyInfo(..),
GBooleanPropertyInfo(..),
gParamSpecCInt, gParamSpecCString, gParamSpecGBoolean,
getGParamSpecGetterSetter,
PropGetSetter(..))
import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString)
import Data.GI.Base.GValue (GValue(..), GValueConstruct(..))
import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject,
newObject)
import Data.GI.Base.Overloading (ResolveAttribute)
import Data.GI.Base.Signals (on, after)
import Data.GI.Base.Utils (dbgLog, callocBytes, freeMem)
foreign import ccall "dbg_g_object_new" g_object_new ::
GType -> CUInt -> Ptr CString -> Ptr a -> IO (Ptr b)
constructGObject :: forall o m. (GObject o, MonadIO m)
=> (ManagedPtr o -> o)
-> [AttrOp o 'AttrConstruct]
-> m o
constructGObject :: forall o (m :: * -> *).
(GObject o, MonadIO m) =>
(ManagedPtr o -> o) -> [AttrOp o 'AttrConstruct] -> m o
constructGObject ManagedPtr o -> o
constructor [AttrOp o 'AttrConstruct]
attrs = IO o -> m o
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO o -> m o) -> IO o -> m o
forall a b. (a -> b) -> a -> b
$ do
props <- [Maybe (GValueConstruct o)] -> [GValueConstruct o]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (GValueConstruct o)] -> [GValueConstruct o])
-> IO [Maybe (GValueConstruct o)] -> IO [GValueConstruct o]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AttrOp o 'AttrConstruct -> IO (Maybe (GValueConstruct o)))
-> [AttrOp o 'AttrConstruct] -> IO [Maybe (GValueConstruct o)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM AttrOp o 'AttrConstruct -> IO (Maybe (GValueConstruct o))
construct [AttrOp o 'AttrConstruct]
attrs
obj <- doConstructGObject constructor props
mapM_ (setSignal obj) attrs
return obj
where
construct :: AttrOp o 'AttrConstruct ->
IO (Maybe (GValueConstruct o))
construct :: AttrOp o 'AttrConstruct -> IO (Maybe (GValueConstruct o))
construct ((AttrLabelProxy attr
_attr :: AttrLabelProxy label) := b
x) =
GValueConstruct o -> Maybe (GValueConstruct o)
forall a. a -> Maybe a
Just (GValueConstruct o -> Maybe (GValueConstruct o))
-> IO (GValueConstruct o) -> IO (Maybe (GValueConstruct o))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
b -> IO (GValueConstruct o)
attrConstruct @(ResolveAttribute label o) b
x
construct ((AttrLabelProxy attr
_attr :: AttrLabelProxy label) :=> IO b
x) =
GValueConstruct o -> Maybe (GValueConstruct o)
forall a. a -> Maybe a
Just (GValueConstruct o -> Maybe (GValueConstruct o))
-> IO (GValueConstruct o) -> IO (Maybe (GValueConstruct o))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO b
x IO b -> (b -> IO (GValueConstruct o)) -> IO (GValueConstruct o)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
b -> IO (GValueConstruct o)
attrConstruct @(ResolveAttribute label o))
construct ((AttrLabelProxy attr
_attr :: AttrLabelProxy label) :&= b
x) = GValueConstruct o -> Maybe (GValueConstruct o)
forall a. a -> Maybe a
Just (GValueConstruct o -> Maybe (GValueConstruct o))
-> IO (GValueConstruct o) -> IO (Maybe (GValueConstruct o))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrTransferTypeConstraint info b) =>
Proxy o -> b -> IO (AttrTransferType info)
attrTransfer @(ResolveAttribute label o) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @o) b
x IO (AttrTransferType info)
-> (AttrTransferType info -> IO (GValueConstruct o))
-> IO (GValueConstruct o)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
AttrSetTypeConstraint info b) =>
b -> IO (GValueConstruct o)
attrConstruct @(ResolveAttribute label o))
construct (On SignalProxy o info
_ (?self::o) => HaskellCallbackType info
_) = Maybe (GValueConstruct o) -> IO (Maybe (GValueConstruct o))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (GValueConstruct o)
forall a. Maybe a
Nothing
construct (After SignalProxy o info
_ (?self::o) => HaskellCallbackType info
_) = Maybe (GValueConstruct o) -> IO (Maybe (GValueConstruct o))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (GValueConstruct o)
forall a. Maybe a
Nothing
setSignal :: GObject o => o -> AttrOp o 'AttrConstruct -> IO ()
setSignal :: GObject o => o -> AttrOp o 'AttrConstruct -> IO ()
setSignal o
obj (On SignalProxy o info
signal (?self::o) => HaskellCallbackType info
callback) = IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ o
-> SignalProxy o info
-> ((?self::o) => HaskellCallbackType info)
-> IO SignalHandlerId
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info
-> ((?self::object) => HaskellCallbackType info)
-> m SignalHandlerId
on o
obj SignalProxy o info
signal HaskellCallbackType info
(?self::o) => HaskellCallbackType info
callback
setSignal o
obj (After SignalProxy o info
signal (?self::o) => HaskellCallbackType info
callback) = IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ o
-> SignalProxy o info
-> ((?self::o) => HaskellCallbackType info)
-> IO SignalHandlerId
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info
-> ((?self::object) => HaskellCallbackType info)
-> m SignalHandlerId
after o
obj SignalProxy o info
signal HaskellCallbackType info
(?self::o) => HaskellCallbackType info
callback
setSignal o
_ AttrOp o 'AttrConstruct
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
new' :: (HasCallStack, MonadIO m, GObject o) =>
(ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o
new' :: forall (m :: * -> *) o.
(HasCallStack, MonadIO m, GObject o) =>
(ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o
new' ManagedPtr o -> o
constructor [m (GValueConstruct o)]
actions = do
props <- [m (GValueConstruct o)] -> m [GValueConstruct o]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [m (GValueConstruct o)]
actions
doConstructGObject constructor props
doConstructGObject :: forall o m. (HasCallStack, GObject o, MonadIO m)
=> (ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject :: forall o (m :: * -> *).
(HasCallStack, GObject o, MonadIO m) =>
(ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject ManagedPtr o -> o
constructor [GValueConstruct o]
props = IO o -> m o
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO o -> m o) -> IO o -> m o
forall a b. (a -> b) -> a -> b
$ do
let nprops :: Int
nprops = [GValueConstruct o] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GValueConstruct o]
props
names <- Int -> IO (Ptr CString)
forall a. Int -> IO (Ptr a)
mallocBytes (Int
nprops Int -> Int -> Int
forall a. Num a => a -> a -> a
* Ptr Any -> Int
forall a. Storable a => a -> Int
sizeOf Ptr Any
forall a. Ptr a
nullPtr)
values <- mallocBytes (nprops * gvalueSize)
fill names values props
gtype <- glibType @o
result <- g_object_new gtype (fromIntegral nprops) names values
freeStrings nprops names
free values
free names
mapM_ (touchManagedPtr . deconstructGValue) props
wrapObject constructor (result :: Ptr o)
where
deconstructGValue :: GValueConstruct o -> GValue
deconstructGValue :: GValueConstruct o -> GValue
deconstructGValue (GValueConstruct String
_ GValue
v) = GValue
v
gvalueSize :: Int
gvalueSize = (Int
24)
{-# LINE 160 "Data/GI/Base/GObject.hsc" #-}
fill :: Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO ()
fill :: Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO ()
fill Ptr CString
_ Ptr GValue
_ [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fill Ptr CString
namePtr Ptr GValue
dataPtr ((GValueConstruct String
str GValue
gvalue):[GValueConstruct o]
xs) =
do cstr <- String -> IO CString
newCString String
str
poke namePtr cstr
withManagedPtr gvalue $ \Ptr GValue
gvalueptr ->
Ptr GValue -> Ptr GValue -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr GValue
dataPtr Ptr GValue
gvalueptr Int
gvalueSize
fill (namePtr `plusPtr` sizeOf nullPtr)
(dataPtr `plusPtr` gvalueSize) xs
freeStrings :: Int -> Ptr CString -> IO ()
freeStrings :: Int -> Ptr CString -> IO ()
freeStrings Int
0 Ptr CString
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeStrings Int
n Ptr CString
namePtr =
do Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
namePtr IO CString -> (CString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO ()
forall a. Ptr a -> IO ()
free
Int -> Ptr CString -> IO ()
freeStrings (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Ptr CString
namePtr Ptr CString -> Int -> Ptr CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Ptr Any -> Int
forall a. Storable a => a -> Int
sizeOf Ptr Any
forall a. Ptr a
nullPtr)
newtype GObjectClass = GObjectClass (Ptr GObjectClass)
class GObject a => DerivedGObject a where
type GObjectParentType a
type GObjectPrivateData a
objectTypeName :: Text
objectClassInit :: GObjectClass -> IO ()
objectInstanceInit :: GObjectClass -> a -> IO (GObjectPrivateData a)
objectInterfaces :: [(IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ()))]
objectInterfaces = []
type CGTypeClassInit = GObjectClass -> IO ()
foreign import ccall "wrapper"
mkClassInit :: CGTypeClassInit -> IO (FunPtr CGTypeClassInit)
type CGTypeInstanceInit o = Ptr o -> GObjectClass -> IO ()
foreign import ccall "wrapper"
mkInstanceInit :: CGTypeInstanceInit o -> IO (FunPtr (CGTypeInstanceInit o))
type CGTypeInterfaceInit = Ptr () -> Ptr () -> IO ()
foreign import ccall "wrapper"
mkInterfaceInit :: CGTypeInterfaceInit -> IO (FunPtr CGTypeInterfaceInit)
type CGTypeInterfaceFinalize = Ptr () -> Ptr () -> IO ()
foreign import ccall "wrapper"
mkInterfaceFinalize :: CGTypeInterfaceFinalize -> IO (FunPtr CGTypeInterfaceFinalize)
foreign import ccall g_type_from_name :: CString -> IO CGType
foreign import ccall "haskell_gi_register_gtype" register_gtype ::
CGType -> CString -> FunPtr CGTypeClassInit ->
FunPtr (CGTypeInstanceInit o) -> Ptr (GSList a) -> IO CGType
foreign import ccall "haskell_gi_gtype_from_class" gtype_from_class ::
GObjectClass -> IO CGType
gtypeFromClass :: GObjectClass -> IO GType
gtypeFromClass :: GObjectClass -> IO GType
gtypeFromClass GObjectClass
klass = CGType -> GType
GType (CGType -> GType) -> IO CGType -> IO GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GObjectClass -> IO CGType
gtype_from_class GObjectClass
klass
foreign import ccall "haskell_gi_gtype_from_instance" gtype_from_instance ::
Ptr o -> IO CGType
gtypeFromInstance :: GObject o => o -> IO GType
gtypeFromInstance :: forall o. GObject o => o -> IO GType
gtypeFromInstance o
obj = o -> (Ptr o -> IO GType) -> IO GType
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO GType) -> IO GType)
-> (Ptr o -> IO GType) -> IO GType
forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
(CGType -> GType
GType (CGType -> GType) -> IO CGType -> IO GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr o -> IO CGType
forall o. Ptr o -> IO CGType
gtype_from_instance Ptr o
objPtr)
foreign import ccall g_param_spec_get_name ::
Ptr GParamSpec -> IO CString
type CPropertyGetter o = Ptr o -> CUInt -> Ptr GValue -> Ptr GParamSpec -> IO ()
foreign import ccall "wrapper"
mkPropertyGetter :: CPropertyGetter o -> IO (FunPtr (CPropertyGetter o))
type CPropertySetter o = Ptr o -> CUInt -> Ptr GValue -> Ptr GParamSpec -> IO ()
foreign import ccall "wrapper"
mkPropertySetter :: CPropertySetter o -> IO (FunPtr (CPropertySetter o))
registerGType :: forall o. (HasCallStack, DerivedGObject o,
GObject (GObjectParentType o),
GObject o) =>
(ManagedPtr o -> o) -> IO GType
registerGType :: forall o.
(HasCallStack, DerivedGObject o, GObject (GObjectParentType o),
GObject o) =>
(ManagedPtr o -> o) -> IO GType
registerGType ManagedPtr o -> o
construct = Text -> (CString -> IO GType) -> IO GType
forall a. Text -> (CString -> IO a) -> IO a
withTextCString (forall a. DerivedGObject a => Text
objectTypeName @o) ((CString -> IO GType) -> IO GType)
-> (CString -> IO GType) -> IO GType
forall a b. (a -> b) -> a -> b
$ \CString
cTypeName -> do
cgtype <- CString -> IO CGType
g_type_from_name CString
cTypeName
if cgtype /= 0
then return (GType cgtype)
else do
classInit <- mkClassInit (unwrapClassInit $ objectClassInit @o)
instanceInit <- mkInstanceInit (unwrapInstanceInit $ objectInstanceInit @o)
(GType parentCGType) <- glibType @(GObjectParentType o)
interfaces <- mapM packInterface (objectInterfaces @o) >>= packGSList
gtype <- GType <$> register_gtype parentCGType cTypeName classInit instanceInit interfaces
mapGSList freeInterfaceInfo interfaces
g_slist_free interfaces
return gtype
where
unwrapInstanceInit :: (GObjectClass -> o -> IO (GObjectPrivateData o)) ->
CGTypeInstanceInit o
unwrapInstanceInit :: (GObjectClass -> o -> IO (GObjectPrivateData o))
-> CGTypeInstanceInit o
unwrapInstanceInit GObjectClass -> o -> IO (GObjectPrivateData o)
instanceInit Ptr o
objPtr GObjectClass
klass = do
privateData <- do
obj <- (ManagedPtr o -> o) -> Ptr o -> IO o
forall a b.
(HasCallStack, GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
newObject ManagedPtr o -> o
construct (Ptr o -> Ptr o
forall a b. Ptr a -> Ptr b
castPtr Ptr o
objPtr :: Ptr o)
instanceInit klass obj
instanceSetPrivateData objPtr privateData
unwrapClassInit :: (GObjectClass -> IO ()) -> CGTypeClassInit
unwrapClassInit :: CGTypeClassInit -> CGTypeClassInit
unwrapClassInit CGTypeClassInit
classInit klass :: GObjectClass
klass@(GObjectClass Ptr GObjectClass
klassPtr) = do
getFunPtr <- CPropertyGetter o -> IO (FunPtr (CPropertyGetter o))
forall o. CPropertyGetter o -> IO (FunPtr (CPropertyGetter o))
mkPropertyGetter CPropertyGetter o
marshallGetter
((\Ptr GObjectClass
hsc_ptr -> Ptr GObjectClass -> Int -> FunPtr (CPropertyGetter o) -> IO ()
forall b. Ptr b -> Int -> FunPtr (CPropertyGetter o) -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr GObjectClass
hsc_ptr Int
32)) klassPtr getFunPtr
{-# LINE 301 "Data/GI/Base/GObject.hsc" #-}
setFunPtr <- mkPropertySetter marshallSetter
((\Ptr GObjectClass
hsc_ptr -> Ptr GObjectClass -> Int -> FunPtr (CPropertyGetter o) -> IO ()
forall b. Ptr b -> Int -> FunPtr (CPropertyGetter o) -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr GObjectClass
hsc_ptr Int
24)) klassPtr setFunPtr
{-# LINE 303 "Data/GI/Base/GObject.hsc" #-}
classInit klass
marshallSetter :: CPropertySetter o
marshallSetter :: CPropertyGetter o
marshallSetter Ptr o
objPtr CUInt
_ Ptr GValue
gvPtr Ptr GParamSpec
pspecPtr = do
maybeGetSet <- Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
forall o. Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
getGParamSpecGetterSetter Ptr GParamSpec
pspecPtr
case maybeGetSet of
Maybe (PropGetSetter o)
Nothing -> do
pspecName <- Ptr GParamSpec -> IO CString
g_param_spec_get_name Ptr GParamSpec
pspecPtr IO CString -> (CString -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
CString -> IO Text
cstringToText
typeName <- glibType @o >>= gtypeName
dbgLog $ "WARNING: Attempting to set unknown property \""
<> pspecName <> "\" of type \"" <> T.pack typeName <> "\"."
Just PropGetSetter o
pgs -> (PropGetSetter o -> Ptr o -> Ptr GValue -> IO ()
forall o. PropGetSetter o -> Ptr o -> Ptr GValue -> IO ()
propSetter PropGetSetter o
pgs) Ptr o
objPtr Ptr GValue
gvPtr
marshallGetter :: CPropertyGetter o
marshallGetter :: CPropertyGetter o
marshallGetter Ptr o
objPtr CUInt
_ Ptr GValue
destGValuePtr Ptr GParamSpec
pspecPtr = do
maybeGetSet <- Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
forall o. Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
getGParamSpecGetterSetter Ptr GParamSpec
pspecPtr
case maybeGetSet of
Maybe (PropGetSetter o)
Nothing -> do
pspecName <- Ptr GParamSpec -> IO CString
g_param_spec_get_name Ptr GParamSpec
pspecPtr IO CString -> (CString -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
CString -> IO Text
cstringToText
typeName <- glibType @o >>= gtypeName
dbgLog $ "WARNING: Attempting to get unknown property \""
<> pspecName <> "\" of type \"" <> T.pack typeName <> "\"."
Just PropGetSetter o
pgs -> (PropGetSetter o -> Ptr o -> Ptr GValue -> IO ()
forall o. PropGetSetter o -> Ptr o -> Ptr GValue -> IO ()
propGetter PropGetSetter o
pgs) Ptr o
objPtr Ptr GValue
destGValuePtr
packInterface :: (IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ()))
-> IO (Ptr CGType)
packInterface :: (IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ()))
-> IO (Ptr CGType)
packInterface (IO GType
ifaceGTypeConstruct, Ptr () -> IO ()
initHs, Maybe (Ptr () -> IO ())
maybeFinalize) = do
gtype <- IO GType
ifaceGTypeConstruct
info <- callocBytes (24)
{-# LINE 332 "Data/GI/Base/GObject.hsc" #-}
initFn <- mkInterfaceInit (unwrapInit initHs)
finalizeFn <- case maybeFinalize of
Just Ptr () -> IO ()
finalizeHs -> CGTypeInterfaceInit -> IO (FunPtr CGTypeInterfaceInit)
mkInterfaceFinalize ((Ptr () -> IO ()) -> CGTypeInterfaceInit
unwrapFinalize Ptr () -> IO ()
finalizeHs)
Maybe (Ptr () -> IO ())
Nothing -> FunPtr CGTypeInterfaceInit -> IO (FunPtr CGTypeInterfaceInit)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunPtr CGTypeInterfaceInit
forall a. FunPtr a
nullFunPtr
(\Ptr Any
hsc_ptr -> Ptr Any -> Int -> FunPtr CGTypeInterfaceInit -> IO ()
forall b. Ptr b -> Int -> FunPtr CGTypeInterfaceInit -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Any
hsc_ptr Int
0) info initFn
{-# LINE 337 "Data/GI/Base/GObject.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 8) info finalizeFn
{-# LINE 338 "Data/GI/Base/GObject.hsc" #-}
combined <- callocBytes ((8) + (8))
{-# LINE 340 "Data/GI/Base/GObject.hsc" #-}
poke combined (gtypeToCGType gtype)
poke (combined `plusPtr` (8)) info
{-# LINE 342 "Data/GI/Base/GObject.hsc" #-}
return combined
unwrapInit :: (Ptr () -> IO ()) -> CGTypeInterfaceInit
unwrapInit :: (Ptr () -> IO ()) -> CGTypeInterfaceInit
unwrapInit Ptr () -> IO ()
f Ptr ()
ptr Ptr ()
_data = Ptr () -> IO ()
f Ptr ()
ptr
unwrapFinalize :: (Ptr () -> IO ()) -> CGTypeInterfaceFinalize
unwrapFinalize :: (Ptr () -> IO ()) -> CGTypeInterfaceInit
unwrapFinalize = (Ptr () -> IO ()) -> CGTypeInterfaceInit
unwrapInit
freeInterfaceInfo :: Ptr CGType -> IO ()
freeInterfaceInfo :: Ptr CGType -> IO ()
freeInterfaceInfo Ptr CGType
combinedPtr = do
info <- Ptr (Ptr Any) -> IO (Ptr Any)
forall a. Storable a => Ptr a -> IO a
peek (Ptr CGType
combinedPtr Ptr CGType -> Int -> Ptr (Ptr Any)
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
8))
{-# LINE 353 "Data/GI/Base/GObject.hsc" #-}
freeMem info
freeMem combinedPtr
privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey = Text -> IO (GQuark (GObjectPrivateData o))
forall a. Text -> IO (GQuark a)
gQuarkFromString (Text -> IO (GQuark (GObjectPrivateData o)))
-> Text -> IO (GQuark (GObjectPrivateData o))
forall a b. (a -> b) -> a -> b
$ forall a. DerivedGObject a => Text
objectTypeName @o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::haskell-gi-private-data"
gobjectGetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>
o -> IO (GObjectPrivateData o)
gobjectGetPrivateData :: forall o.
(HasCallStack, DerivedGObject o) =>
o -> IO (GObjectPrivateData o)
gobjectGetPrivateData o
obj = do
key <- forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey @o
maybePriv <- gobjectGetUserData obj key
case maybePriv of
Just GObjectPrivateData o
priv -> GObjectPrivateData o -> IO (GObjectPrivateData o)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GObjectPrivateData o
priv
Maybe (GObjectPrivateData o)
Nothing -> do
case ManagedPtr Any -> Maybe CallStack
forall a. ManagedPtr a -> Maybe CallStack
managedPtrAllocCallStack (o -> ManagedPtr Any
forall a b. Coercible a b => a -> b
coerce o
obj) of
Maybe CallStack
Nothing -> String -> IO (GObjectPrivateData o)
forall a. HasCallStack => String -> a
error (String
"Failed to get private data pointer!\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Set the env var HASKELL_GI_DEBUG_MEM=1 to get more info.")
Just CallStack
cs -> o
-> (Ptr o -> IO (GObjectPrivateData o))
-> IO (GObjectPrivateData o)
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO (GObjectPrivateData o)) -> IO (GObjectPrivateData o))
-> (Ptr o -> IO (GObjectPrivateData o))
-> IO (GObjectPrivateData o)
forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr -> do
let errMsg :: String
errMsg = String
"Failed to get private data pointer for" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ptr o -> String
forall a. Show a => a -> String
show Ptr o
objPtr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"!\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Callstack for allocation was:\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
cs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\n"
String -> IO (GObjectPrivateData o)
forall a. HasCallStack => String -> a
error String
errMsg
foreign import ccall g_object_get_qdata ::
Ptr a -> GQuark b -> IO (Ptr c)
gobjectGetUserData :: (HasCallStack, GObject o) => o -> GQuark a -> IO (Maybe a)
gobjectGetUserData :: forall o a.
(HasCallStack, GObject o) =>
o -> GQuark a -> IO (Maybe a)
gobjectGetUserData o
obj GQuark a
key = do
dataPtr <- o -> (Ptr o -> IO (Ptr ())) -> IO (Ptr ())
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO (Ptr ())) -> IO (Ptr ()))
-> (Ptr o -> IO (Ptr ())) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
Ptr o -> GQuark a -> IO (Ptr ())
forall a b c. Ptr a -> GQuark b -> IO (Ptr c)
g_object_get_qdata Ptr o
objPtr GQuark a
key
if dataPtr /= nullPtr
then Just <$> deRefStablePtr (castPtrToStablePtr dataPtr)
else return Nothing
foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr ::
GDestroyNotify (Ptr ())
foreign import ccall g_object_set_qdata_full ::
Ptr a -> GQuark b -> Ptr () -> GDestroyNotify (Ptr ()) -> IO ()
gobjectSetUserData :: (HasCallStack, GObject o) =>
o -> GQuark a -> a -> IO ()
gobjectSetUserData :: forall o a.
(HasCallStack, GObject o) =>
o -> GQuark a -> a -> IO ()
gobjectSetUserData o
obj GQuark a
key a
value = o -> (Ptr o -> IO ()) -> IO ()
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO ()) -> IO ()) -> (Ptr o -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
Ptr o -> GQuark a -> a -> IO ()
forall o a.
(HasCallStack, GObject o) =>
Ptr o -> GQuark a -> a -> IO ()
instanceSetUserData Ptr o
objPtr GQuark a
key a
value
gobjectModifyUserData :: (HasCallStack, GObject o) =>
o -> GQuark a -> (Maybe a -> a) -> IO ()
gobjectModifyUserData :: forall o a.
(HasCallStack, GObject o) =>
o -> GQuark a -> (Maybe a -> a) -> IO ()
gobjectModifyUserData o
obj GQuark a
key Maybe a -> a
transform = do
userData <- o -> GQuark a -> IO (Maybe a)
forall o a.
(HasCallStack, GObject o) =>
o -> GQuark a -> IO (Maybe a)
gobjectGetUserData o
obj GQuark a
key
gobjectSetUserData obj key (transform userData)
instanceSetUserData :: (HasCallStack, GObject o) =>
Ptr o -> GQuark a -> a -> IO ()
instanceSetUserData :: forall o a.
(HasCallStack, GObject o) =>
Ptr o -> GQuark a -> a -> IO ()
instanceSetUserData Ptr o
objPtr GQuark a
key a
value = do
stablePtr <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
value
g_object_set_qdata_full objPtr key (castStablePtrToPtr stablePtr)
ptr_to_hs_free_stable_ptr
gobjectSetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>
o -> GObjectPrivateData o -> IO ()
gobjectSetPrivateData :: forall o.
(HasCallStack, DerivedGObject o) =>
o -> GObjectPrivateData o -> IO ()
gobjectSetPrivateData o
obj GObjectPrivateData o
value = o -> (Ptr o -> IO ()) -> IO ()
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO ()) -> IO ()) -> (Ptr o -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
Ptr o -> GObjectPrivateData o -> IO ()
forall o.
(HasCallStack, DerivedGObject o) =>
Ptr o -> GObjectPrivateData o -> IO ()
instanceSetPrivateData Ptr o
objPtr GObjectPrivateData o
value
instanceSetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>
Ptr o -> GObjectPrivateData o -> IO ()
instanceSetPrivateData :: forall o.
(HasCallStack, DerivedGObject o) =>
Ptr o -> GObjectPrivateData o -> IO ()
instanceSetPrivateData Ptr o
objPtr GObjectPrivateData o
priv = do
key <- forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey @o
instanceSetUserData objPtr key priv
foreign import ccall g_object_class_install_property ::
GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
gobjectModifyPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>
o -> (GObjectPrivateData o -> GObjectPrivateData o)
-> IO ()
gobjectModifyPrivateData :: forall o.
(HasCallStack, DerivedGObject o) =>
o -> (GObjectPrivateData o -> GObjectPrivateData o) -> IO ()
gobjectModifyPrivateData o
obj GObjectPrivateData o -> GObjectPrivateData o
transform = do
private <- o -> IO (GObjectPrivateData o)
forall o.
(HasCallStack, DerivedGObject o) =>
o -> IO (GObjectPrivateData o)
gobjectGetPrivateData o
obj
gobjectSetPrivateData obj (transform private)
gobjectInstallProperty :: DerivedGObject o =>
GObjectClass -> PropertyInfo o a -> IO ()
gobjectInstallProperty :: forall o a.
DerivedGObject o =>
GObjectClass -> PropertyInfo o a -> IO ()
gobjectInstallProperty GObjectClass
klass PropertyInfo o a
propInfo = do
pspec <- PropertyInfo o a -> IO GParamSpec
forall o a. GObject o => PropertyInfo o a -> IO GParamSpec
gParamSpecValue PropertyInfo o a
propInfo
withManagedPtr pspec $ \Ptr GParamSpec
pspecPtr ->
GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
g_object_class_install_property GObjectClass
klass CUInt
1 Ptr GParamSpec
pspecPtr
gobjectInstallCIntProperty :: DerivedGObject o =>
GObjectClass -> CIntPropertyInfo o -> IO ()
gobjectInstallCIntProperty :: forall o.
DerivedGObject o =>
GObjectClass -> CIntPropertyInfo o -> IO ()
gobjectInstallCIntProperty GObjectClass
klass CIntPropertyInfo o
propInfo = do
pspec <- CIntPropertyInfo o -> IO GParamSpec
forall o. GObject o => CIntPropertyInfo o -> IO GParamSpec
gParamSpecCInt CIntPropertyInfo o
propInfo
withManagedPtr pspec $ \Ptr GParamSpec
pspecPtr ->
GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
g_object_class_install_property GObjectClass
klass CUInt
1 Ptr GParamSpec
pspecPtr
gobjectInstallCStringProperty :: DerivedGObject o =>
GObjectClass -> CStringPropertyInfo o -> IO ()
gobjectInstallCStringProperty :: forall o.
DerivedGObject o =>
GObjectClass -> CStringPropertyInfo o -> IO ()
gobjectInstallCStringProperty GObjectClass
klass CStringPropertyInfo o
propInfo = do
pspec <- CStringPropertyInfo o -> IO GParamSpec
forall o. GObject o => CStringPropertyInfo o -> IO GParamSpec
gParamSpecCString CStringPropertyInfo o
propInfo
withManagedPtr pspec $ \Ptr GParamSpec
pspecPtr ->
GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
g_object_class_install_property GObjectClass
klass CUInt
1 Ptr GParamSpec
pspecPtr
gobjectInstallGBooleanProperty :: DerivedGObject o =>
GObjectClass -> GBooleanPropertyInfo o -> IO ()
gobjectInstallGBooleanProperty :: forall o.
DerivedGObject o =>
GObjectClass -> GBooleanPropertyInfo o -> IO ()
gobjectInstallGBooleanProperty GObjectClass
klass GBooleanPropertyInfo o
propInfo = do
pspec <- GBooleanPropertyInfo o -> IO GParamSpec
forall o. GObject o => GBooleanPropertyInfo o -> IO GParamSpec
gParamSpecGBoolean GBooleanPropertyInfo o
propInfo
withManagedPtr pspec $ \Ptr GParamSpec
pspecPtr ->
GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
g_object_class_install_property GObjectClass
klass CUInt
1 Ptr GParamSpec
pspecPtr