{-# 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
    , 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)

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

-- | Construct the given `GObject`, given a set of actions
-- constructing desired `GValue`s to set at construction time.
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

-- | Construct the `GObject` given the list of `GValueConstruct`s.
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
  -- 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.
  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 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 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

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

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

  -- | List of interfaces implemented by the type. Each element is a
  -- triplet (@gtype@, @interfaceInit@, @interfaceFinalize@), where
  -- @gtype :: IO GType@ is a constructor for the type of the
  -- interface, @interfaceInit :: Ptr () -> IO ()@ is a function that
  -- registers the callbacks in the interface, and @interfaceFinalize
  -- :: Maybe (Ptr () -> IO ())@ is the (optional) finalizer.
  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

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

-- | 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 = 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)  -- Already registered
    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

-- | 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 = 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"

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

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

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

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

-- | 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 = 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 :: 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 ()

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

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

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

-- | Add a `${type gboolean}`-valued property to the given object class.
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