{-# 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 Control.Monad.IO.Class (MonadIO, liftIO)

import Data.Proxy (Proxy(..))
import Data.Coerce (coerce)

import Foreign.C (CUInt(..), CString, newCString)

{-# LINE 51 "Data/GI/Base/GObject.hsc" #-}
import Foreign


{-# LINE 56 "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.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 :: (ManagedPtr o -> o) -> [AttrOp o 'AttrConstruct] -> m o
constructGObject ManagedPtr o -> o
constructor [AttrOp o 'AttrConstruct]
attrs = IO o -> m o
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
  [GValueConstruct o]
props <- (AttrOp o 'AttrConstruct -> IO (GValueConstruct o))
-> [AttrOp o 'AttrConstruct] -> IO [GValueConstruct o]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttrOp o 'AttrConstruct -> IO (GValueConstruct o)
construct [AttrOp o 'AttrConstruct]
attrs
  (ManagedPtr o -> o) -> [GValueConstruct o] -> IO o
forall o (m :: * -> *).
(GObject o, MonadIO m) =>
(ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject ManagedPtr o -> o
constructor [GValueConstruct o]
props
  where
    construct :: AttrOp o 'AttrConstruct ->
                 IO (GValueConstruct o)
    construct :: AttrOp o 'AttrConstruct -> IO (GValueConstruct o)
construct ((AttrLabelProxy attr
_attr :: AttrLabelProxy label) := b
x) =
      b -> IO (GValueConstruct o)
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) =
      IO b
x IO b -> (b -> IO (GValueConstruct o)) -> IO (GValueConstruct o)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall o b.
(AttrInfo (ResolveAttribute attr o),
 AttrBaseTypeConstraint (ResolveAttribute attr o) o,
 AttrSetTypeConstraint (ResolveAttribute attr o) b) =>
b -> IO (GValueConstruct o)
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) =
      Proxy o -> b -> IO (AttrTransferType (ResolveAttribute attr o))
forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
 AttrTransferTypeConstraint info b) =>
Proxy o -> b -> IO (AttrTransferType info)
attrTransfer @(ResolveAttribute label o) (Proxy o
forall k (t :: k). Proxy t
Proxy @o) b
x IO (AttrTransferType info)
-> (AttrTransferType info -> IO (GValueConstruct o))
-> IO (GValueConstruct o)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      forall o b.
(AttrInfo (ResolveAttribute attr o),
 AttrBaseTypeConstraint (ResolveAttribute attr o) o,
 AttrSetTypeConstraint (ResolveAttribute attr o) b) =>
b -> IO (GValueConstruct o)
forall info o b.
(AttrInfo info, AttrBaseTypeConstraint info o,
 AttrSetTypeConstraint info b) =>
b -> IO (GValueConstruct o)
attrConstruct @(ResolveAttribute label o)

-- | 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' :: (ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o
new' ManagedPtr o -> o
constructor [m (GValueConstruct o)]
actions = do
  [GValueConstruct o]
props <- [m (GValueConstruct o)] -> m [GValueConstruct o]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m (GValueConstruct o)]
actions
  (ManagedPtr o -> o) -> [GValueConstruct o] -> m o
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 :: (ManagedPtr o -> o) -> [GValueConstruct o] -> m o
doConstructGObject ManagedPtr o -> o
constructor [GValueConstruct o]
props = IO o -> m o
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 (t :: * -> *) a. Foldable t => t a -> Int
length [GValueConstruct o]
props
  Ptr CString
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)
  Ptr GValue
values <- Int -> IO (Ptr GValue)
forall a. Int -> IO (Ptr a)
mallocBytes (Int
nprops Int -> Int -> Int
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 <- TypedObject o => IO GType
forall a. TypedObject a => IO GType
glibType @o
  Ptr o
result <- GType -> CUInt -> Ptr CString -> Ptr GValue -> IO (Ptr o)
forall a b. GType -> CUInt -> Ptr CString -> Ptr a -> IO (Ptr b)
g_object_new GType
gtype (Int -> CUInt
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
  Ptr GValue -> IO ()
forall a. Ptr a -> IO ()
free Ptr GValue
values
  Ptr CString -> IO ()
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.
  (GValueConstruct o -> IO ()) -> [GValueConstruct o] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GValue -> IO ()
forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr (GValue -> IO ())
-> (GValueConstruct o -> GValue) -> GValueConstruct o -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GValueConstruct o -> GValue
deconstructGValue) [GValueConstruct o]
props
  (ManagedPtr o -> o) -> Ptr o -> IO o
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 145 "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
_ [] = () -> IO ()
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
           Ptr CString -> CString -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CString
namePtr CString
cstr
           GValue -> (Ptr GValue -> IO ()) -> IO ()
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GValue
gvalue ((Ptr GValue -> IO ()) -> IO ()) -> (Ptr GValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
           Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO ()
fill (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)
                (Ptr GValue
dataPtr Ptr GValue -> Int -> Ptr GValue
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
_ = () -> IO ()
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 (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)

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

-- | Find the `GType` for a given `GObject`.
gtypeFromInstance :: GObject o => o -> IO GType
gtypeFromInstance :: 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))

-- | 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 :: (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 (DerivedGObject o => Text
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
cgtype <- CString -> IO CGType
g_type_from_name CString
cTypeName
  if CGType
cgtype CGType -> CGType -> Bool
forall a. Eq a => a -> a -> Bool
/= CGType
0
    then GType -> IO GType
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 (CGTypeClassInit -> CGTypeClassInit)
-> CGTypeClassInit -> CGTypeClassInit
forall a b. (a -> b) -> a -> b
$ DerivedGObject o => CGTypeClassInit
forall a. DerivedGObject a => CGTypeClassInit
objectClassInit @o)
      FunPtr (CGTypeInstanceInit o)
instanceInit <- CGTypeInstanceInit o -> IO (FunPtr (CGTypeInstanceInit o))
forall o.
CGTypeInstanceInit o -> IO (FunPtr (CGTypeInstanceInit o))
mkInstanceInit ((GObjectClass -> o -> IO (GObjectPrivateData o))
-> CGTypeInstanceInit o
unwrapInstanceInit ((GObjectClass -> o -> IO (GObjectPrivateData o))
 -> CGTypeInstanceInit o)
-> (GObjectClass -> o -> IO (GObjectPrivateData o))
-> CGTypeInstanceInit o
forall a b. (a -> b) -> a -> b
$ DerivedGObject o => GObjectClass -> o -> IO (GObjectPrivateData o)
forall a.
DerivedGObject a =>
GObjectClass -> a -> IO (GObjectPrivateData a)
objectInstanceInit @o)
      (GType CGType
parentCGType) <- TypedObject (GObjectParentType o) => IO GType
forall a. TypedObject a => IO GType
glibType @(GObjectParentType o)
      CGType -> GType
GType (CGType -> GType) -> IO CGType -> IO GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CGType
-> CString
-> FunPtr CGTypeClassInit
-> FunPtr (CGTypeInstanceInit o)
-> IO CGType
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 <- (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)
         GObjectClass -> o -> IO (GObjectPrivateData o)
instanceInit GObjectClass
klass o
obj
       Ptr o -> GObjectPrivateData o -> IO ()
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 <- 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 a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr GObjectClass
hsc_ptr Int
32)) Ptr GObjectClass
klassPtr FunPtr (CPropertyGetter o)
getFunPtr
{-# LINE 263 "Data/GI/Base/GObject.hsc" #-}
       setFunPtr <- mkPropertySetter marshallSetter
       ((\Ptr GObjectClass
hsc_ptr -> Ptr GObjectClass -> Int -> FunPtr (CPropertyGetter o) -> IO ()
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 265 "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 <- Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
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 IO CString -> (CString -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
CString -> IO Text
cstringToText
           String
typeName <- TypedObject o => IO GType
forall a. TypedObject a => IO GType
glibType @o IO GType -> (GType -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GType -> IO String
gtypeName
           Text -> IO ()
dbgLog (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"WARNING: Attempting to set unknown property \""
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pspecName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" of type \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
typeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"."
         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
       Maybe (PropGetSetter o)
maybeGetSet <- Ptr GParamSpec -> IO (Maybe (PropGetSetter o))
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 IO CString -> (CString -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
CString -> IO Text
cstringToText
           String
typeName <- TypedObject o => IO GType
forall a. TypedObject a => IO GType
glibType @o IO GType -> (GType -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GType -> IO String
gtypeName
           Text -> IO ()
dbgLog (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"WARNING: Attempting to get unknown property \""
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pspecName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" of type \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
typeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"."
         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

-- | Quark with the key to the private data for this object type.
privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey :: 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
$ DerivedGObject o => Text
forall a. DerivedGObject a => Text
objectTypeName @o Text -> Text -> Text
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 :: o -> IO (GObjectPrivateData o)
gobjectGetPrivateData o
obj = do
  GQuark (GObjectPrivateData o)
key <- DerivedGObject o => IO (GQuark (GObjectPrivateData o))
forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey @o
  Maybe (GObjectPrivateData o)
maybePriv <- o
-> GQuark (GObjectPrivateData o)
-> IO (Maybe (GObjectPrivateData o))
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 -> GObjectPrivateData o -> IO (GObjectPrivateData o)
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
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)

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

foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr ::
        FunPtr (GDestroyNotify a)

foreign import ccall g_object_set_qdata_full ::
        Ptr a -> GQuark b -> Ptr () -> FunPtr (GDestroyNotify ()) -> 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 :: 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

-- | A combination of `gobjectGetUserData` and `gobjectSetUserData`,
-- for convenience.
gobjectModifyUserData :: (HasCallStack, GObject o) =>
                   o -> GQuark a -> (Maybe a -> a) -> IO ()
gobjectModifyUserData :: o -> GQuark a -> (Maybe a -> a) -> IO ()
gobjectModifyUserData o
obj GQuark a
key Maybe a -> a
transform = do
  Maybe a
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
  o -> GQuark a -> a -> IO ()
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 :: Ptr o -> GQuark a -> a -> IO ()
instanceSetUserData Ptr o
objPtr GQuark a
key a
value = do
  StablePtr a
stablePtr <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
value
  Ptr o -> GQuark a -> Ptr () -> FunPtr (GDestroyNotify ()) -> IO ()
forall a b.
Ptr a -> GQuark b -> Ptr () -> FunPtr (GDestroyNotify ()) -> IO ()
g_object_set_qdata_full Ptr o
objPtr GQuark a
key (StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
stablePtr)
                             FunPtr (GDestroyNotify ())
forall a. FunPtr (GDestroyNotify a)
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 :: 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

-- | Set the private data for a given instance.
instanceSetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>
                          Ptr o -> GObjectPrivateData o -> IO ()
instanceSetPrivateData :: Ptr o -> GObjectPrivateData o -> IO ()
instanceSetPrivateData Ptr o
objPtr GObjectPrivateData o
priv = do
  GQuark (GObjectPrivateData o)
key <- DerivedGObject o => IO (GQuark (GObjectPrivateData o))
forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))
privateKey @o
  Ptr o
-> GQuark (GObjectPrivateData o) -> GObjectPrivateData o -> IO ()
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 :: o -> (GObjectPrivateData o -> GObjectPrivateData o) -> IO ()
gobjectModifyPrivateData o
obj GObjectPrivateData o -> GObjectPrivateData o
transform = do
  GObjectPrivateData o
private <- o -> IO (GObjectPrivateData o)
forall o.
(HasCallStack, DerivedGObject o) =>
o -> IO (GObjectPrivateData o)
gobjectGetPrivateData o
obj
  o -> GObjectPrivateData o -> IO ()
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 :: GObjectClass -> PropertyInfo o a -> IO ()
gobjectInstallProperty GObjectClass
klass PropertyInfo o a
propInfo = do
  GParamSpec
pspec <- PropertyInfo o a -> IO GParamSpec
forall o a. GObject o => PropertyInfo o a -> IO GParamSpec
gParamSpecValue PropertyInfo o a
propInfo
  GParamSpec -> (Ptr GParamSpec -> IO ()) -> IO ()
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GParamSpec
pspec ((Ptr GParamSpec -> IO ()) -> IO ())
-> (Ptr GParamSpec -> IO ()) -> IO ()
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 :: GObjectClass -> CIntPropertyInfo o -> IO ()
gobjectInstallCIntProperty GObjectClass
klass CIntPropertyInfo o
propInfo = do
  GParamSpec
pspec <- CIntPropertyInfo o -> IO GParamSpec
forall o. GObject o => CIntPropertyInfo o -> IO GParamSpec
gParamSpecCInt CIntPropertyInfo o
propInfo
  GParamSpec -> (Ptr GParamSpec -> IO ()) -> IO ()
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GParamSpec
pspec ((Ptr GParamSpec -> IO ()) -> IO ())
-> (Ptr GParamSpec -> IO ()) -> IO ()
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 :: GObjectClass -> CStringPropertyInfo o -> IO ()
gobjectInstallCStringProperty GObjectClass
klass CStringPropertyInfo o
propInfo = do
  GParamSpec
pspec <- CStringPropertyInfo o -> IO GParamSpec
forall o. GObject o => CStringPropertyInfo o -> IO GParamSpec
gParamSpecCString CStringPropertyInfo o
propInfo
  GParamSpec -> (Ptr GParamSpec -> IO ()) -> IO ()
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GParamSpec
pspec ((Ptr GParamSpec -> IO ()) -> IO ())
-> (Ptr GParamSpec -> IO ()) -> IO ()
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