{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
-- For HasCallStack compatibility
{-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-}
{-# LANGUAGE TypeApplications #-}

-- | We wrap most objects in a "managed pointer", which is basically a
-- 'ForeignPtr' of the appropriate type together with a notion of
-- "disowning", which means not running the finalizers passed upon
-- construction of the object upon garbage collection. The routines in
-- this module deal with the memory management of such managed
-- pointers.

module Data.GI.Base.ManagedPtr
    (
    -- * Managed pointers
      newManagedPtr
    , newManagedPtr'
    , newManagedPtr_
    , withManagedPtr
    , maybeWithManagedPtr
    , withManagedPtrList
    , withTransient
    , unsafeManagedPtrGetPtr
    , unsafeManagedPtrCastPtr
    , touchManagedPtr
    , disownManagedPtr

    -- * Safe casting
    , castTo
    , unsafeCastTo
    , checkInstanceType

    -- * Wrappers
    , newObject
    , wrapObject
    , releaseObject
    , unrefObject
    , disownObject
    , newBoxed
    , wrapBoxed
    , copyBoxed
    , copyBoxedPtr
    , freeBoxed
    , disownBoxed
    , wrapPtr
    , newPtr
    , copyBytes
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (when, void)
import Control.Monad.Fix (mfix)

import Data.Coerce (coerce)
import Data.IORef (newIORef, readIORef, writeIORef, IORef)
import Data.Maybe (isNothing, isJust)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif

import Foreign.C (CInt(..))
import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr)
import Foreign.ForeignPtr (FinalizerPtr, touchForeignPtr, newForeignPtr_)
import qualified Foreign.Concurrent as FC
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

import Data.GI.Base.BasicTypes
import Data.GI.Base.CallStack (CallStack, HasCallStack,
                               prettyCallStack, callStack)
import Data.GI.Base.Utils

import qualified Data.Text as T

import System.IO (hPutStrLn, stderr)
import System.Environment (lookupEnv)

-- | Thin wrapper over `Foreign.Concurrent.newForeignPtr`.
newManagedPtr :: HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr :: forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr IO ()
finalizer = do
  IORef (Maybe CallStack)
isDisownedRef <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
  Bool
dbgMode <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"HASKELL_GI_DEBUG_MEM"
  let dbgCallStack :: Maybe CallStack
dbgCallStack = if Bool
dbgMode
                     then forall a. a -> Maybe a
Just HasCallStack => CallStack
callStack
                     else forall a. Maybe a
Nothing
  ForeignPtr a
fPtr <- forall a. Ptr a -> IO () -> IO (ForeignPtr a)
FC.newForeignPtr Ptr a
ptr (forall a.
IO ()
-> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack) -> IO ()
ownedFinalizer IO ()
finalizer Ptr a
ptr Maybe CallStack
dbgCallStack IORef (Maybe CallStack)
isDisownedRef)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ManagedPtr {
               managedForeignPtr :: ForeignPtr a
managedForeignPtr = ForeignPtr a
fPtr
             , managedPtrAllocCallStack :: Maybe CallStack
managedPtrAllocCallStack = Maybe CallStack
dbgCallStack
             , managedPtrIsDisowned :: IORef (Maybe CallStack)
managedPtrIsDisowned = IORef (Maybe CallStack)
isDisownedRef
             }

-- | Run the finalizer for an owned pointer, assuming it has now been
-- disowned.
ownedFinalizer :: IO () -> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack)
               -> IO ()
ownedFinalizer :: forall a.
IO ()
-> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack) -> IO ()
ownedFinalizer IO ()
finalizer Ptr a
ptr Maybe CallStack
allocCallStack IORef (Maybe CallStack)
callStackRef = do
  Maybe CallStack
cs <- forall a. IORef a -> IO a
readIORef IORef (Maybe CallStack)
callStackRef
  -- cs will be @Just cs@ whenever the pointer has been disowned.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe CallStack
cs) forall a b. (a -> b) -> a -> b
$ case Maybe CallStack
allocCallStack of
                          Just CallStack
acs -> do
                            forall a. Ptr a -> CallStack -> IO ()
printAllocDebug Ptr a
ptr CallStack
acs
                            IO ()
finalizer
                            Text -> IO ()
dbgLog (String -> Text
T.pack String
"Released successfully.\n")
                          Maybe CallStack
Nothing -> IO ()
finalizer

-- | Print some debug diagnostics for an allocation.
printAllocDebug :: Ptr a -> CallStack -> IO ()
printAllocDebug :: forall a. Ptr a -> CallStack -> IO ()
printAllocDebug Ptr a
ptr CallStack
allocCS =
  (Text -> IO ()
dbgLog forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String
"Releasing <" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Ptr a
ptr forall a. Semigroup a => a -> a -> a
<> String
">. "
                     forall a. Semigroup a => a -> a -> a
<> String
"Callstack for allocation was:\n"
                     forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
allocCS forall a. Semigroup a => a -> a -> a
<> String
"\n\n")

foreign import ccall "dynamic"
   mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()

-- | Version of `newManagedPtr` taking a `FinalizerPtr` and a
-- corresponding `Ptr`, as in `Foreign.ForeignPtr.newForeignPtr`.
newManagedPtr' :: HasCallStack => FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' :: forall a.
HasCallStack =>
FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' FinalizerPtr a
finalizer Ptr a
ptr = forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr (forall a. FinalizerPtr a -> Ptr a -> IO ()
mkFinalizer FinalizerPtr a
finalizer Ptr a
ptr)

-- | Thin wrapper over `Foreign.Concurrent.newForeignPtr_`.
newManagedPtr_ :: Ptr a -> IO (ManagedPtr a)
newManagedPtr_ :: forall a. Ptr a -> IO (ManagedPtr a)
newManagedPtr_ Ptr a
ptr = do
  IORef (Maybe CallStack)
isDisownedRef <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
  ForeignPtr a
fPtr <- forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr a
ptr
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ManagedPtr {
               managedForeignPtr :: ForeignPtr a
managedForeignPtr = ForeignPtr a
fPtr
             , managedPtrAllocCallStack :: Maybe CallStack
managedPtrAllocCallStack = forall a. Maybe a
Nothing
             , managedPtrIsDisowned :: IORef (Maybe CallStack)
managedPtrIsDisowned = IORef (Maybe CallStack)
isDisownedRef
             }

-- | Do not run the finalizers upon garbage collection of the
-- `ManagedPtr`.
disownManagedPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr a
managed = do
  Ptr a
ptr <- forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr a
managed
  forall a. IORef a -> a -> IO ()
writeIORef (forall a. ManagedPtr a -> IORef (Maybe CallStack)
managedPtrIsDisowned ManagedPtr a
c) (forall a. a -> Maybe a
Just HasCallStack => CallStack
callStack)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr)
    where c :: ManagedPtr a
c = forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
managed

-- | Perform an IO action on the 'Ptr' inside a managed pointer.
withManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> (Ptr a -> IO c) -> IO c
withManagedPtr :: forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
managed Ptr a -> IO c
action = do
  Ptr a
ptr <- forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr a
managed
  c
result <- Ptr a -> IO c
action Ptr a
ptr
  forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr a
managed
  forall (m :: * -> *) a. Monad m => a -> m a
return c
result

-- | Like `withManagedPtr`, but accepts a `Maybe` type. If the passed
-- value is `Nothing` the inner action will be executed with a
-- `nullPtr` argument.
maybeWithManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => Maybe a -> (Ptr a -> IO c) -> IO c
maybeWithManagedPtr :: forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
Maybe a -> (Ptr a -> IO c) -> IO c
maybeWithManagedPtr Maybe a
Nothing Ptr a -> IO c
action = Ptr a -> IO c
action forall a. Ptr a
nullPtr
maybeWithManagedPtr (Just a
managed) Ptr a -> IO c
action = forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
managed Ptr a -> IO c
action

-- | Perform an IO action taking a list of 'Ptr' on a list of managed
-- pointers.
withManagedPtrList :: (HasCallStack, ManagedPtrNewtype a) => [a] -> ([Ptr a] -> IO c) -> IO c
withManagedPtrList :: forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
[a] -> ([Ptr a] -> IO c) -> IO c
withManagedPtrList [a]
managedList [Ptr a] -> IO c
action = do
  [Ptr a]
ptrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr [a]
managedList
  c
result <- [Ptr a] -> IO c
action [Ptr a]
ptrs
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr [a]
managedList
  forall (m :: * -> *) a. Monad m => a -> m a
return c
result

-- | Perform the IO action with a transient managed pointer. The
-- managed pointer will be valid while calling the action, but will be
-- disowned as soon as the action finished.
withTransient :: (HasCallStack, ManagedPtrNewtype a)
              => Ptr a -> (a -> IO b) -> IO b
withTransient :: forall a b.
(HasCallStack, ManagedPtrNewtype a) =>
Ptr a -> (a -> IO b) -> IO b
withTransient Ptr a
ptr a -> IO b
action = do
  a
managed <- coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ptr a -> IO (ManagedPtr a)
newManagedPtr_ Ptr a
ptr
  b
r <- a -> IO b
action a
managed
  Ptr Any
_ <- forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr a
managed
  forall (m :: * -> *) a. Monad m => a -> m a
return b
r

-- | Return the 'Ptr' in a given managed pointer. As the name says,
-- this is potentially unsafe: the given 'Ptr' may only be used
-- /before/ a call to 'touchManagedPtr'. This function is of most
-- interest to the autogenerated bindings, for hand-written code
-- 'withManagedPtr' is almost always a better choice.
unsafeManagedPtrGetPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr :: forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr = forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
unsafeManagedPtrCastPtr

-- | Same as 'unsafeManagedPtrGetPtr', but is polymorphic on the
-- return type.
unsafeManagedPtrCastPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) =>
                           a -> IO (Ptr b)
unsafeManagedPtrCastPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
unsafeManagedPtrCastPtr a
m = do
    let c :: ManagedPtr a
c = forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
        ptr :: Ptr b
ptr = (forall a b. Ptr a -> Ptr b
castPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr a
c
    Maybe CallStack
disowned <- forall a. IORef a -> IO a
readIORef (forall a. ManagedPtr a -> IORef (Maybe CallStack)
managedPtrIsDisowned ManagedPtr a
c)
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Ptr b
ptr) (forall a. HasCallStack => Ptr a -> CallStack -> IO (Ptr a)
notOwnedWarning Ptr b
ptr) Maybe CallStack
disowned

-- | Print a warning when we try to access a disowned foreign ptr.
notOwnedWarning :: HasCallStack => Ptr a -> CallStack -> IO (Ptr a)
notOwnedWarning :: forall a. HasCallStack => Ptr a -> CallStack -> IO (Ptr a)
notOwnedWarning Ptr a
ptr CallStack
cs = do
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"WARNING: Accessing a disowned pointer <" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Ptr a
ptr
                     forall a. [a] -> [a] -> [a]
++ String
">, this may lead to crashes.\n\n"
                     forall a. [a] -> [a] -> [a]
++ String
"• Callstack for the unsafe access to the pointer:\n"
                     forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack HasCallStack => CallStack
callStack forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                     forall a. [a] -> [a] -> [a]
++ String
"• The pointer was disowned at:\n"
                     forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
cs forall a. [a] -> [a] -> [a]
++ String
"\n")
  forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr

-- | Ensure that the 'Ptr' in the given managed pointer is still alive
-- (i.e. it has not been garbage collected by the runtime) at the
-- point that this is called.
touchManagedPtr :: forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr :: forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr a
m = let c :: ManagedPtr a
c = forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
                    in (forall a. ForeignPtr a -> IO ()
touchForeignPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr a
c

-- Safe casting machinery
foreign import ccall unsafe "check_object_type"
    c_check_object_type :: Ptr o -> CGType -> IO CInt

-- | Check whether the given object is an instance of the given type.
checkInstanceType :: (ManagedPtrNewtype o, TypedObject o) =>
                     o -> GType -> IO Bool
checkInstanceType :: forall o.
(ManagedPtrNewtype o, TypedObject o) =>
o -> GType -> IO Bool
checkInstanceType o
obj (GType CGType
cgtype) = 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
  CInt
check <- forall o. Ptr o -> CGType -> IO CInt
c_check_object_type Ptr o
objPtr CGType
cgtype
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CInt
check forall a. Eq a => a -> a -> Bool
/= CInt
0

-- | Cast from one object type to another, checking that the cast is
-- valid. If it is not, we return `Nothing`. Usage:
--
-- > maybeWidget <- castTo Widget label
castTo :: forall o o'. (HasCallStack,
                        ManagedPtrNewtype o, TypedObject o,
                        ManagedPtrNewtype o', TypedObject o',
                        GObject o') =>
          (ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo :: forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o', GObject o') =>
(ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo ManagedPtr o' -> o'
constructor o
obj = do
  GType
gtype <- forall a. TypedObject a => IO GType
glibType @o'
  Bool
isInstance <- forall o.
(ManagedPtrNewtype o, TypedObject o) =>
o -> GType -> IO Bool
checkInstanceType o
obj GType
gtype
  if Bool
isInstance
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr o' -> o'
constructor forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr o
obj
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Cast a typed object to a new type (without any assumption that
-- both types descend from `GObject`), assuming that the cast will
-- succeed. This function will call `error` if the cast is illegal.
unsafeCastTo :: forall o o'. (HasCallStack,
                              ManagedPtrNewtype o, TypedObject o,
                              ManagedPtrNewtype o', TypedObject o') =>
                (ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo :: forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo ManagedPtr o' -> o'
constructor o
obj = do
    GType
gtype <- forall a. TypedObject a => IO GType
glibType @o'
    Bool
isInstance <- forall o.
(ManagedPtrNewtype o, TypedObject o) =>
o -> GType -> IO Bool
checkInstanceType o
obj GType
gtype
    if Bool -> Bool
not Bool
isInstance
      then do
      String
srcType <- 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
      String
destType <- 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
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unsafeCastTo :: invalid conversion from " forall a. [a] -> [a] -> [a]
++ String
srcType forall a. [a] -> [a] -> [a]
++ String
" to "
        forall a. [a] -> [a] -> [a]
++ String
destType forall a. [a] -> [a] -> [a]
++ String
" requested."
      else forall (m :: * -> *) a. Monad m => a -> m a
return (ManagedPtr o' -> o'
constructor forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr o
obj)

-- Reference counting for constructors
foreign import ccall "&dbg_g_object_unref"
    ptr_to_g_object_unref :: FunPtr (Ptr a -> IO ())

foreign import ccall "g_object_ref_sink" g_object_ref_sink ::
    Ptr a -> IO (Ptr a)

-- | Print a warning when receiving a null pointer in a function that
-- did not expect one, for easier debugging.
nullPtrWarning :: String -> CallStack -> IO ()
nullPtrWarning :: String -> CallStack -> IO ()
nullPtrWarning String
fn CallStack
cs =
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"WARNING: Trying to wrap a null pointer in " forall a. [a] -> [a] -> [a]
++ String
quotedFn
                     forall a. [a] -> [a] -> [a]
++ String
", this may lead to crashes.\n\n"
                     forall a. [a] -> [a] -> [a]
++ String
"• Callstack for the unsafe call to "
                     forall a. [a] -> [a] -> [a]
++ String
quotedFn forall a. [a] -> [a] -> [a]
++ String
":\n"
                     forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
cs forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                     forall a. [a] -> [a] -> [a]
++ String
"This is probably a bug in the introspection data,\n"
                     forall a. [a] -> [a] -> [a]
++ String
"please report it at https://github.com/haskell-gi/haskell-gi/issues")
  where quotedFn :: String
quotedFn = String
"‘" forall a. [a] -> [a] -> [a]
++ String
fn forall a. [a] -> [a] -> [a]
++ String
"’"

-- | Construct a Haskell wrapper for a 'GObject', increasing its
-- reference count, or taking ownership of the floating reference if
-- there is one.
newObject :: (HasCallStack, GObject a, GObject b) =>
             (ManagedPtr a -> a) -> Ptr b -> IO a
newObject :: forall a b.
(HasCallStack, GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
newObject ManagedPtr a -> a
constructor Ptr b
ptr = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr b
ptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr) (String -> CallStack -> IO ()
nullPtrWarning String
"newObject" HasCallStack => CallStack
callStack)
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> IO (Ptr a)
g_object_ref_sink Ptr b
ptr
  ManagedPtr a
fPtr <- forall a.
HasCallStack =>
FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' forall a. FunPtr (Ptr a -> IO ())
ptr_to_g_object_unref forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr Ptr b
ptr
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | Same as 'newObject', but we steal ownership of the object.
wrapObject :: forall a b. (HasCallStack, GObject a, GObject b) =>
              (ManagedPtr a -> a) -> Ptr b -> IO a
wrapObject :: forall a b.
(HasCallStack, GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
wrapObject ManagedPtr a -> a
constructor Ptr b
ptr = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr b
ptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr) (String -> CallStack -> IO ()
nullPtrWarning String
"wrapObject" HasCallStack => CallStack
callStack)
  ManagedPtr a
fPtr <- forall a.
HasCallStack =>
FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' forall a. FunPtr (Ptr a -> IO ())
ptr_to_g_object_unref forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr Ptr b
ptr
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | Unref the given `GObject` and disown it. Use this if you want to
-- manually release the memory associated to a given `GObject`
-- (assuming that no other reference to the underlying C object exists)
-- before the garbage collector does it. It is typically not safe to
-- access the `GObject` after calling this function.
releaseObject :: (HasCallStack, GObject a) => a -> IO ()
releaseObject :: forall a. (HasCallStack, GObject a) => a -> IO ()
releaseObject a
obj = do
  Ptr Any
ptr <- forall a b. (HasCallStack, GObject a) => a -> IO (Ptr b)
disownObject a
obj
  forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
obj
  forall a. Ptr a -> IO ()
dbg_g_object_unref Ptr Any
ptr

-- It is fine to use unsafe here, since all this does is schedule an
-- idle callback. The scheduling itself will never block for a long
-- time, or call back into Haskell.
foreign import ccall unsafe "dbg_g_object_unref"
        dbg_g_object_unref :: Ptr a -> IO ()

-- | Decrease the reference count of the given 'GObject'. The memory
-- associated with the object may be released if the reference count
-- reaches 0.
unrefObject :: (HasCallStack, GObject a) => a -> IO ()
unrefObject :: forall a. (HasCallStack, GObject a) => a -> IO ()
unrefObject a
obj = forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
obj forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
  forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
obj
  forall a. Ptr a -> IO ()
dbg_g_object_unref Ptr a
ptr

-- | Print some debug info (if the right environment valiable is set)
-- about the object being disowned.
foreign import ccall "dbg_g_object_disown"
        dbg_g_object_disown :: Ptr a -> IO ()

-- | Disown a GObject, that is, do not unref the associated foreign
-- GObject when the Haskell object gets garbage collected. Returns the
-- pointer to the underlying GObject.
disownObject :: (HasCallStack, GObject a) => a -> IO (Ptr b)
disownObject :: forall a b. (HasCallStack, GObject a) => a -> IO (Ptr b)
disownObject a
obj = forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
obj forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
  forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
obj
  forall a. Ptr a -> IO ()
dbg_g_object_disown Ptr a
ptr
  forall a b. Ptr a -> Ptr b
castPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr a
obj

-- It is fine to use unsafe here, since all this does is schedule an
-- idle callback. The scheduling itself will never block for a long
-- time, or call back into Haskell.
foreign import ccall unsafe "boxed_free_helper" boxed_free_helper ::
    CGType -> Ptr a -> IO ()

foreign import ccall "g_boxed_copy" g_boxed_copy ::
    CGType -> Ptr a -> IO (Ptr a)

-- | Construct a Haskell wrapper for the given boxed object. We make a
-- copy of the object.
newBoxed :: forall a. (HasCallStack, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a
newBoxed :: forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
newBoxed ManagedPtr a -> a
constructor Ptr a
ptr = do
  GType CGType
gtype <- forall a. TypedObject a => IO GType
glibType @a
  Ptr a
ptr' <- forall a. CGType -> Ptr a -> IO (Ptr a)
g_boxed_copy CGType
gtype Ptr a
ptr
  ManagedPtr a
fPtr <- forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr' (forall a. CGType -> Ptr a -> IO ()
boxed_free_helper CGType
gtype Ptr a
ptr')
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | Like 'newBoxed', but we do not make a copy (we "steal" the passed
-- object, so now it is managed by the Haskell runtime).
wrapBoxed :: forall a. (HasCallStack, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed :: forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr a -> a
constructor Ptr a
ptr = do
  GType CGType
gtype <- forall a. TypedObject a => IO GType
glibType @a
  ManagedPtr a
fPtr <- forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr (forall a. CGType -> Ptr a -> IO ()
boxed_free_helper CGType
gtype Ptr a
ptr)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | Make a copy of the given boxed object.
copyBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO (Ptr a)
copyBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO (Ptr a)
copyBoxed a
b = do
  GType CGType
gtype <- forall a. TypedObject a => IO GType
glibType @a
  forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
b (forall a. CGType -> Ptr a -> IO (Ptr a)
g_boxed_copy CGType
gtype)

-- | Like 'copyBoxed', but acting directly on a pointer, instead of a
-- managed pointer.
copyBoxedPtr :: forall a. GBoxed a => Ptr a -> IO (Ptr a)
copyBoxedPtr :: forall a. GBoxed a => Ptr a -> IO (Ptr a)
copyBoxedPtr Ptr a
ptr = do
  GType CGType
gtype <- forall a. TypedObject a => IO GType
glibType @a
  forall a. CGType -> Ptr a -> IO (Ptr a)
g_boxed_copy CGType
gtype Ptr a
ptr

foreign import ccall "g_boxed_free" g_boxed_free ::
    CGType -> Ptr a -> IO ()

-- | Free the memory associated with a boxed object. Note that this
-- disowns the associated `ManagedPtr` via `disownManagedPtr`.
freeBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO ()
freeBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO ()
freeBoxed a
boxed = do
  GType CGType
gtype <- forall a. TypedObject a => IO GType
glibType @a
  Ptr Any
ptr <- forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr a
boxed
  forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
boxed
  forall a. CGType -> Ptr a -> IO ()
g_boxed_free CGType
gtype Ptr Any
ptr

-- | Disown a boxed object, that is, do not free the associated
-- foreign GBoxed when the Haskell object gets garbage
-- collected. Returns the pointer to the underlying `GBoxed`.
disownBoxed :: (HasCallStack, GBoxed a) => a -> IO (Ptr a)
disownBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO (Ptr a)
disownBoxed = forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr

-- | Wrap a pointer, taking ownership of it.
wrapPtr :: (HasCallStack, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapPtr :: forall a.
(HasCallStack, BoxedPtr a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapPtr ManagedPtr a -> a
constructor Ptr a
ptr = forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \a
wrapped -> do
  ManagedPtr a
fPtr <- forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr (forall a. BoxedPtr a => a -> IO ()
boxedPtrFree a
wrapped)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | Wrap a pointer, making a copy of the data.
newPtr :: (HasCallStack, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a
newPtr :: forall a.
(HasCallStack, BoxedPtr a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
newPtr ManagedPtr a -> a
constructor Ptr a
ptr = do
  ManagedPtr a
tmpWrap <- forall a. Ptr a -> IO (ManagedPtr a)
newManagedPtr_ Ptr a
ptr
  a
ptr' <- forall a. BoxedPtr a => a -> IO a
boxedPtrCopy (ManagedPtr a -> a
constructor ManagedPtr a
tmpWrap)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! a
ptr'

-- | Make a copy of a wrapped pointer using @memcpy@ into a freshly
-- allocated memory region of the given size.
copyBytes :: (HasCallStack, CallocPtr a) => Int -> Ptr a -> IO (Ptr a)
copyBytes :: forall a. (HasCallStack, CallocPtr a) => Int -> Ptr a -> IO (Ptr a)
copyBytes Int
size Ptr a
ptr = do
  Ptr a
ptr' <- forall a. CallocPtr a => IO (Ptr a)
boxedPtrCalloc
  forall a b. Ptr a -> Ptr b -> Int -> IO ()
memcpy Ptr a
ptr' Ptr a
ptr Int
size
  forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr'

foreign import ccall unsafe "g_thread_self" g_thread_self :: IO (Ptr ())

-- | Same as `dbgDeallocPtr`, but for `ManagedPtr`s, and no callstack
-- needs to be provided.
dbgDealloc :: (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc :: forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
m = do
  Maybe String
env <- String -> IO (Maybe String)
lookupEnv String
"HASKELL_GI_DEBUG_MEM"
  case Maybe String
env of
    Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
_ -> do
      let mPtr :: ManagedPtr a
mPtr = forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
          ptr :: Ptr a
ptr = (forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr a
mPtr
      Ptr ()
threadPtr <- IO (Ptr ())
g_thread_self
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Releasing <" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Ptr a
ptr forall a. [a] -> [a] -> [a]
++ String
"> from thread ["
                         forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Ptr ()
threadPtr forall a. [a] -> [a] -> [a]
++ String
"].\n"
                         forall a. [a] -> [a] -> [a]
++ (case forall a. ManagedPtr a -> Maybe CallStack
managedPtrAllocCallStack ManagedPtr a
mPtr of
                               Just CallStack
allocCS -> String
"• Callstack for allocation:\n"
                                               forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
allocCS forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                               Maybe CallStack
Nothing -> String
"")
                         forall a. [a] -> [a] -> [a]
++ String
"• CallStack for deallocation:\n"
                         forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack HasCallStack => CallStack
callStack forall a. [a] -> [a] -> [a]
++ String
"\n")