{-# LINE 1 "Data/GI/Base/GObject.hsc" #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}

-- | This module constains helpers for dealing with `GObject`-derived
-- types.

module Data.GI.Base.GObject
    ( -- * Constructing new `GObject`s
      constructGObject
    , new'

    -- * User data
    , gobjectGetUserData
    , gobjectSetUserData
    , gobjectModifyUserData

    -- * Deriving new object types
    , DerivedGObject(..)
    , registerGType
    , gobjectGetPrivateData
    , gobjectSetPrivateData
    , gobjectModifyPrivateData

    , GObjectClass(..)
    , gtypeFromClass
    , gtypeFromInstance

    -- * Installing properties for derived objects
    , gobjectInstallProperty
    , gobjectInstallCIntProperty
    , gobjectInstallCStringProperty
    ) 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)
import Foreign.StablePtr (newStablePtr, deRefStablePtr,
                          castStablePtrToPtr, castPtrToStablePtr)
import Foreign.Storable (Storable(peek, poke, pokeByteOff, sizeOf))
import Foreign (mallocBytes, copyBytes, free)


{-# LINE 57 "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,
                                GDestroyNotify, ManagedPtr(..), GParamSpec(..),
                                TypedObject(glibType),
                                gtypeName)
import Data.GI.Base.BasicConversions (withTextCString, cstringToText)
import Data.GI.Base.CallStack (HasCallStack, prettyCallStack)
import Data.GI.Base.GParamSpec (PropertyInfo(..),
                                gParamSpecValue,
                                CIntPropertyInfo(..), CStringPropertyInfo(..),
                                gParamSpecCInt, gParamSpecCString,
                                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)



foreign import ccall "dbg_g_object_new" g_object_new ::
    GType -> CUInt -> Ptr CString -> Ptr a -> IO (Ptr b)

-- | Construct a GObject given the constructor and a list of settable
-- attributes. See `Data.GI.Base.Constructible.new` for a more general
-- version.
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  [GValueConstruct o]
props <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttrOp o 'AttrConstruct -> IO (Maybe (GValueConstruct o))
construct [AttrOp o 'AttrConstruct]
attrs
  o
obj <- forall o (m :: * -> *).
(GObject o, MonadIO m) =>
(ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject ManagedPtr o -> o
constructor [GValueConstruct o]
props
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GObject o => o -> AttrOp o 'AttrConstruct -> IO ()
setSignal o
obj) [AttrOp o 'AttrConstruct]
attrs
  forall (m :: * -> *) a. Monad m => a -> m a
return o
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) =
      forall a. a -> Maybe a
Just 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) =
      forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO b
x 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) = forall a. a -> Maybe a
Just 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 {k} (t :: k). Proxy t
Proxy @o) b
x 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
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    construct (After SignalProxy o info
_ (?self::o) => HaskellCallbackType info
_) = forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 (?self::o) => HaskellCallbackType info
callback
    setSignal o
obj (After SignalProxy o info
signal (?self::o) => HaskellCallbackType info
callback) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 (?self::o) => HaskellCallbackType info
callback
    setSignal o
_ AttrOp o 'AttrConstruct
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Construct the given `GObject`, given a set of actions
-- constructing desired `GValue`s to set at construction time.
new' :: (MonadIO m, GObject o) =>
        (ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o
new' :: forall (m :: * -> *) o.
(MonadIO m, GObject o) =>
(ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o
new' ManagedPtr o -> o
constructor [m (GValueConstruct o)]
actions = do
  [GValueConstruct o]
props <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m (GValueConstruct o)]
actions
  forall o (m :: * -> *).
(GObject o, MonadIO m) =>
(ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject ManagedPtr o -> o
constructor [GValueConstruct o]
props

-- | Construct the `GObject` given the list of `GValueConstruct`s.
doConstructGObject :: forall o m. (GObject o, MonadIO m)
                      => (ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject :: forall o (m :: * -> *).
(GObject o, MonadIO m) =>
(ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject ManagedPtr o -> o
constructor [GValueConstruct o]
props = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  let nprops :: Int
nprops = forall (t :: * -> *) a. Foldable t => t a -> Int
length [GValueConstruct o]
props
  Ptr CString
names <- forall a. Int -> IO (Ptr a)
mallocBytes (Int
nprops forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf forall a. Ptr a
nullPtr)
  Ptr GValue
values <- forall a. Int -> IO (Ptr a)
mallocBytes (Int
nprops forall a. Num a => a -> a -> a
* Int
gvalueSize)
  Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO ()
fill Ptr CString
names Ptr GValue
values [GValueConstruct o]
props
  GType
gtype <- forall a. TypedObject a => IO GType
glibType @o
  Ptr o
result <- forall a b. GType -> CUInt -> Ptr CString -> Ptr a -> IO (Ptr b)
g_object_new GType
gtype (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nprops) Ptr CString
names Ptr GValue
values
  Int -> Ptr CString -> IO ()
freeStrings Int
nprops Ptr CString
names
  forall a. Ptr a -> IO ()
free Ptr GValue
values
  forall a. Ptr a -> IO ()
free Ptr CString
names
  -- Make sure that the GValues defining the GProperties are still
  -- alive at this point (so, in particular, they are still alive when
  -- g_object_new is called). Without this the GHC garbage collector
  -- may free the GValues before g_object_new is called, which will
  -- unref the referred to objects, which may drop the last reference
  -- to the contained objects. g_object_new then tries to access the
  -- (now invalid) contents of the GValue, and mayhem ensues.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. GValueConstruct o -> GValue
deconstructGValue) [GValueConstruct o]
props
  forall a b.
(HasCallStack, GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
wrapObject ManagedPtr o -> o
constructor (Ptr o
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 157 "Data/GI/Base/GObject.hsc" #-}

    -- Fill in the memory associated with the parameters.
    fill :: Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO ()
    fill :: Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO ()
fill Ptr CString
_ Ptr GValue
_ [] = 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 CString
cstr <- String -> IO CString
newCString String
str
           forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CString
namePtr CString
cstr
           forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GValue
gvalue forall a b. (a -> b) -> a -> b
$ \Ptr GValue
gvalueptr ->
                                     forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr GValue
dataPtr Ptr GValue
gvalueptr Int
gvalueSize
           Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO ()
fill (Ptr CString
namePtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Storable a => a -> Int
sizeOf forall a. Ptr a
nullPtr)
                (Ptr GValue
dataPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
gvalueSize) [GValueConstruct o]
xs

    -- Free the strings in the GParameter array (the GValues will be
    -- freed separately).
    freeStrings :: Int -> Ptr CString -> IO ()
    freeStrings :: Int -> Ptr CString -> IO ()
freeStrings Int
0 Ptr CString
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    freeStrings Int
n Ptr CString
namePtr =
        do forall a. Storable a => Ptr a -> IO a
peek Ptr CString
namePtr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Ptr a -> IO ()
free
           Int -> Ptr CString -> IO ()
freeStrings (Int
nforall a. Num a => a -> a -> a
-Int
1) (Ptr CString
namePtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Storable a => a -> Int
sizeOf forall a. Ptr a
nullPtr)

-- | Wrapper around @GObjectClass@ on the C-side.
newtype GObjectClass = GObjectClass (Ptr GObjectClass)

-- | This typeclass contains the data necessary for defining a new
-- `GObject` type from Haskell.
class GObject a => DerivedGObject a where
  -- | The parent type
  type GObjectParentType a
  -- | Type of the private data for each instance.
  type GObjectPrivateData a

  -- | Name of the type, it should be unique.
  objectTypeName     :: Text
  -- | Code to run when the class is inited. This is a good place to
  -- register signals and properties for the type.
  objectClassInit    :: GObjectClass -> IO ()
  -- | Code to run when each instance of the type is
  -- constructed. Returns the private data to be associated with the
  -- new instance (use `gobjectGetPrivateData` and
  -- `gobjectSetPrivateData` to manipulate this further).
  objectInstanceInit :: GObjectClass -> a -> IO (GObjectPrivateData a)

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))

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) -> IO CGType

foreign import ccall "haskell_gi_gtype_from_class" gtype_from_class ::
        GObjectClass -> IO CGType

-- | Find the `GType` associated to a given `GObjectClass`.
gtypeFromClass :: GObjectClass -> IO GType
gtypeFromClass :: GObjectClass -> IO GType
gtypeFromClass GObjectClass
klass = CGType -> GType
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

-- | Find the `GType` for a given `GObject`.
gtypeFromInstance :: GObject o => o -> IO GType
gtypeFromInstance :: forall o. GObject o => o -> IO GType
gtypeFromInstance o
obj = forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
                            (CGType -> GType
GType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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))

-- | Register the given type into the @GObject@ type system and return
-- the resulting `GType`, if it has not been registered already. If
-- the type has been registered already the existing `GType` will be
-- returned instead.
--
-- Note that for this function to work the type must be an instance of
-- `DerivedGObject`.
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 = forall a. Text -> (CString -> IO a) -> IO a
withTextCString (forall a. DerivedGObject a => Text
objectTypeName @o) forall a b. (a -> b) -> a -> b
$ \CString
cTypeName -> do
  CGType
cgtype <- CString -> IO CGType
g_type_from_name CString
cTypeName
  if CGType
cgtype forall a. Eq a => a -> a -> Bool
/= CGType
0
    then forall (m :: * -> *) a. Monad m => a -> m a
return (CGType -> GType
GType CGType
cgtype)  -- Already registered
    else do
      FunPtr CGTypeClassInit
classInit <- CGTypeClassInit -> IO (FunPtr CGTypeClassInit)
mkClassInit (CGTypeClassInit -> CGTypeClassInit
unwrapClassInit forall a b. (a -> b) -> a -> b
$ forall a. DerivedGObject a => CGTypeClassInit
objectClassInit @o)
      FunPtr (CGTypeInstanceInit o)
instanceInit <- forall o.
CGTypeInstanceInit o -> IO (FunPtr (CGTypeInstanceInit o))
mkInstanceInit ((GObjectClass -> o -> IO (GObjectPrivateData o))
-> CGTypeInstanceInit o
unwrapInstanceInit forall a b. (a -> b) -> a -> b
$ forall a.
DerivedGObject a =>
GObjectClass -> a -> IO (GObjectPrivateData a)
objectInstanceInit @o)
      (GType CGType
parentCGType) <- forall a. TypedObject a => IO GType
glibType @(GObjectParentType o)
      CGType -> GType
GType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall o.
CGType
-> CString
-> FunPtr CGTypeClassInit
-> FunPtr (CGTypeInstanceInit o)
-> IO CGType
register_gtype CGType
parentCGType CString
cTypeName FunPtr CGTypeClassInit
classInit FunPtr (CGTypeInstanceInit o)
instanceInit

   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
       GObjectPrivateData o
privateData <- do
         o
obj <- forall a b.
(HasCallStack, GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
newObject ManagedPtr o -> o
construct (forall a b. Ptr a -> Ptr b
castPtr Ptr o
objPtr :: Ptr o)
         GObjectClass -> o -> IO (GObjectPrivateData o)
instanceInit GObjectClass
klass o
obj
       forall o.
(HasCallStack, DerivedGObject o) =>
Ptr o -> GObjectPrivateData o -> IO ()
instanceSetPrivateData Ptr o
objPtr GObjectPrivateData o
privateData

     unwrapClassInit :: (GObjectClass -> IO ()) -> CGTypeClassInit
     unwrapClassInit :: CGTypeClassInit -> CGTypeClassInit
unwrapClassInit CGTypeClassInit
classInit klass :: GObjectClass
klass@(GObjectClass Ptr GObjectClass
klassPtr) = do
       FunPtr (CPropertyGetter o)
getFunPtr <- forall o. CPropertyGetter o -> IO (FunPtr (CPropertyGetter o))
mkPropertyGetter CPropertyGetter o
marshallGetter
       ((\Ptr GObjectClass
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr GObjectClass
hsc_ptr Int
32)) Ptr GObjectClass
klassPtr FunPtr (CPropertyGetter o)
getFunPtr
{-# LINE 275 "Data/GI/Base/GObject.hsc" #-}
       setFunPtr <- mkPropertySetter marshallSetter
       ((\Ptr GObjectClass
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr GObjectClass
hsc_ptr Int
24)) Ptr GObjectClass
klassPtr FunPtr (CPropertyGetter o)
setFunPtr
{-# LINE 277 "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
       Maybe (PropGetSetter o)
maybeGetSet <- forall o. Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
getGParamSpecGetterSetter Ptr GParamSpec
pspecPtr
       case Maybe (PropGetSetter o)
maybeGetSet of
         Maybe (PropGetSetter o)
Nothing -> do
           Text
pspecName <- Ptr GParamSpec -> IO CString
g_param_spec_get_name Ptr GParamSpec
pspecPtr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
cstringToText
           String
typeName <- forall a. TypedObject a => IO GType
glibType @o forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GType -> IO String
gtypeName
           Text -> IO ()
dbgLog forall a b. (a -> b) -> a -> b
$ Text
"WARNING: Attempting to set unknown property \""
                    forall a. Semigroup a => a -> a -> a
<> Text
pspecName forall a. Semigroup a => a -> a -> a
<> Text
"\" of type \"" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
typeName forall a. Semigroup a => a -> a -> a
<> Text
"\"."
         Just PropGetSetter o
pgs -> (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
       Maybe (PropGetSetter o)
maybeGetSet <- forall o. Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
getGParamSpecGetterSetter Ptr GParamSpec
pspecPtr
       case Maybe (PropGetSetter o)
maybeGetSet of
         Maybe (PropGetSetter o)
Nothing -> do
           Text
pspecName <- Ptr GParamSpec -> IO CString
g_param_spec_get_name Ptr GParamSpec
pspecPtr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
cstringToText
           String
typeName <- forall a. TypedObject a => IO GType
glibType @o forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GType -> IO String
gtypeName
           Text -> IO ()
dbgLog forall a b. (a -> b) -> a -> b
$ Text
"WARNING: Attempting to get unknown property \""
                    forall a. Semigroup a => a -> a -> a
<> Text
pspecName forall a. Semigroup a => a -> a -> a
<> Text
"\" of type \"" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
typeName forall a. Semigroup a => a -> a -> a
<> Text
"\"."
         Just PropGetSetter o
pgs -> (forall o. PropGetSetter o -> Ptr o -> Ptr GValue -> IO ()
propGetter PropGetSetter o
pgs) Ptr o
objPtr Ptr GValue
destGValuePtr

-- | Quark with the key to the private data for this object type.
privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey = forall a. Text -> IO (GQuark a)
gQuarkFromString forall a b. (a -> b) -> a -> b
$ forall a. DerivedGObject a => Text
objectTypeName @o forall a. Semigroup a => a -> a -> a
<> Text
"::haskell-gi-private-data"

-- | Get the private data associated with the given object.
gobjectGetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>
                            o -> IO (GObjectPrivateData o)
gobjectGetPrivateData :: forall o.
(HasCallStack, DerivedGObject o) =>
o -> IO (GObjectPrivateData o)
gobjectGetPrivateData o
obj = do
  GQuark (GObjectPrivateData o)
key <- forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey @o
  Maybe (GObjectPrivateData o)
maybePriv <- forall o a.
(HasCallStack, GObject o) =>
o -> GQuark a -> IO (Maybe a)
gobjectGetUserData o
obj GQuark (GObjectPrivateData o)
key
  case Maybe (GObjectPrivateData o)
maybePriv of
    Just GObjectPrivateData o
priv -> forall (m :: * -> *) a. Monad m => a -> m a
return GObjectPrivateData o
priv
    Maybe (GObjectPrivateData o)
Nothing -> do
      case forall a. ManagedPtr a -> Maybe CallStack
managedPtrAllocCallStack (coerce :: forall a b. Coercible a b => a -> b
coerce o
obj) of
        Maybe CallStack
Nothing -> forall a. HasCallStack => String -> a
error (String
"Failed to get private data pointer!\n"
                          forall a. Semigroup a => a -> a -> a
<> String
"Set the env var HASKELL_GI_DEBUG_MEM=1 to get more info.")
        Just CallStack
cs -> forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr -> do
          let errMsg :: String
errMsg = String
"Failed to get private data pointer for" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Ptr o
objPtr forall a. Semigroup a => a -> a -> a
<> String
"!\n"
                       forall a. Semigroup a => a -> a -> a
<> String
"Callstack for allocation was:\n"
                       forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
cs forall a. Semigroup a => a -> a -> a
<> String
"\n\n"
          forall a. HasCallStack => String -> a
error String
errMsg

foreign import ccall g_object_get_qdata ::
   Ptr a -> GQuark b -> IO (Ptr c)

-- | Get the value of a given key for the object.
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
  Ptr ()
dataPtr <- forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
                 forall a b c. Ptr a -> GQuark b -> IO (Ptr c)
g_object_get_qdata Ptr o
objPtr GQuark a
key
  if Ptr ()
dataPtr forall a. Eq a => a -> a -> Bool
/= forall a. Ptr a
nullPtr
    then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. StablePtr a -> IO a
deRefStablePtr (forall a. Ptr () -> StablePtr a
castPtrToStablePtr Ptr ()
dataPtr)
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
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 ()

-- | Set the value of the user data for the given `GObject` to a
-- `StablePtr` to the given Haskell object. The `StablePtr` will be
-- freed when the object is destroyed, or the value is replaced.
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 = forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
  forall o a.
(HasCallStack, GObject o) =>
Ptr o -> GQuark a -> a -> IO ()
instanceSetUserData Ptr o
objPtr GQuark a
key a
value

-- | A combination of `gobjectGetUserData` and `gobjectSetUserData`,
-- for convenience.
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
  Maybe a
userData <- forall o a.
(HasCallStack, GObject o) =>
o -> GQuark a -> IO (Maybe a)
gobjectGetUserData o
obj GQuark a
key
  forall o a.
(HasCallStack, GObject o) =>
o -> GQuark a -> a -> IO ()
gobjectSetUserData o
obj GQuark a
key (Maybe a -> a
transform Maybe a
userData)

-- | Like `gobjectSetUserData`, but it works on the raw object pointer.
-- Note that this is unsafe, unless used in a context where we are sure that
-- the GC will not release the object while we run.
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
stablePtr <- forall a. a -> IO (StablePtr a)
newStablePtr a
value
  forall a b.
Ptr a -> GQuark b -> Ptr () -> GDestroyNotify (Ptr ()) -> IO ()
g_object_set_qdata_full Ptr o
objPtr GQuark a
key (forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
stablePtr)
                             GDestroyNotify (Ptr ())
ptr_to_hs_free_stable_ptr

-- | Set the private data associated with the given object.
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 = forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr ->
  forall o.
(HasCallStack, DerivedGObject o) =>
Ptr o -> GObjectPrivateData o -> IO ()
instanceSetPrivateData Ptr o
objPtr GObjectPrivateData o
value

-- | Set the private data for a given instance.
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
  GQuark (GObjectPrivateData o)
key <- forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey @o
  forall o a.
(HasCallStack, GObject o) =>
Ptr o -> GQuark a -> a -> IO ()
instanceSetUserData Ptr o
objPtr GQuark (GObjectPrivateData o)
key GObjectPrivateData o
priv

foreign import ccall g_object_class_install_property ::
   GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()

-- | Modify the private data for the given object.
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
  GObjectPrivateData o
private <- forall o.
(HasCallStack, DerivedGObject o) =>
o -> IO (GObjectPrivateData o)
gobjectGetPrivateData o
obj
  forall o.
(HasCallStack, DerivedGObject o) =>
o -> GObjectPrivateData o -> IO ()
gobjectSetPrivateData o
obj (GObjectPrivateData o -> GObjectPrivateData o
transform GObjectPrivateData o
private)

-- | Add a Haskell object-valued property to the given object class.
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
  GParamSpec
pspec <- forall o a. GObject o => PropertyInfo o a -> IO GParamSpec
gParamSpecValue PropertyInfo o a
propInfo
  forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GParamSpec
pspec forall a b. (a -> b) -> a -> b
$ \Ptr GParamSpec
pspecPtr ->
    GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
g_object_class_install_property GObjectClass
klass CUInt
1 Ptr GParamSpec
pspecPtr

-- | Add a `Foreign.C.CInt`-valued property to the given object class.
gobjectInstallCIntProperty :: DerivedGObject o =>
                              GObjectClass -> CIntPropertyInfo o -> IO ()
gobjectInstallCIntProperty :: forall o.
DerivedGObject o =>
GObjectClass -> CIntPropertyInfo o -> IO ()
gobjectInstallCIntProperty GObjectClass
klass CIntPropertyInfo o
propInfo = do
  GParamSpec
pspec <- forall o. GObject o => CIntPropertyInfo o -> IO GParamSpec
gParamSpecCInt CIntPropertyInfo o
propInfo
  forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GParamSpec
pspec forall a b. (a -> b) -> a -> b
$ \Ptr GParamSpec
pspecPtr ->
    GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
g_object_class_install_property GObjectClass
klass CUInt
1 Ptr GParamSpec
pspecPtr

-- | Add a `CString`-valued property to the given object class.
gobjectInstallCStringProperty :: DerivedGObject o =>
                              GObjectClass -> CStringPropertyInfo o -> IO ()
gobjectInstallCStringProperty :: forall o.
DerivedGObject o =>
GObjectClass -> CStringPropertyInfo o -> IO ()
gobjectInstallCStringProperty GObjectClass
klass CStringPropertyInfo o
propInfo = do
  GParamSpec
pspec <- forall o. GObject o => CStringPropertyInfo o -> IO GParamSpec
gParamSpecCString CStringPropertyInfo o
propInfo
  forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GParamSpec
pspec forall a b. (a -> b) -> a -> b
$ \Ptr GParamSpec
pspecPtr ->
    GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()
g_object_class_install_property GObjectClass
klass CUInt
1 Ptr GParamSpec
pspecPtr