{-# 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
    , withNewObject
    , 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
  isDisownedRef <- Maybe CallStack -> IO (IORef (Maybe CallStack))
forall a. a -> IO (IORef a)
newIORef Maybe CallStack
forall a. Maybe a
Nothing
  dbgMode <- isJust <$> lookupEnv "HASKELL_GI_DEBUG_MEM"
  let dbgCallStack = if Bool
dbgMode
                     then CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack
                     else Maybe CallStack
forall a. Maybe a
Nothing
  fPtr <- FC.newForeignPtr ptr (ownedFinalizer finalizer ptr dbgCallStack isDisownedRef)
  return $ ManagedPtr {
               managedForeignPtr = fPtr
             , managedPtrAllocCallStack = dbgCallStack
             , managedPtrIsDisowned = 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
  cs <- IORef (Maybe CallStack) -> IO (Maybe CallStack)
forall a. IORef a -> IO a
readIORef IORef (Maybe CallStack)
callStackRef
  -- cs will be @Just cs@ whenever the pointer has been disowned.
  when (isNothing cs) $ case allocCallStack of
                          Just CallStack
acs -> do
                            Ptr a -> CallStack -> IO ()
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 (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String
"Releasing <" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ptr a -> String
forall a. Show a => a -> String
show Ptr a
ptr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">. "
                     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
allocCS String -> String -> String
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 = Ptr a -> IO () -> IO (ManagedPtr a)
forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr (FinalizerPtr a -> Ptr a -> IO ()
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
  isDisownedRef <- Maybe CallStack -> IO (IORef (Maybe CallStack))
forall a. a -> IO (IORef a)
newIORef Maybe CallStack
forall a. Maybe a
Nothing
  fPtr <- newForeignPtr_ ptr
  return $ ManagedPtr {
               managedForeignPtr = fPtr
             , managedPtrAllocCallStack = Nothing
             , managedPtrIsDisowned = 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 -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr a
managed
  writeIORef (managedPtrIsDisowned c) (Just callStack)
  return (castPtr ptr)
    where c :: ManagedPtr a
c = a -> ManagedPtr a
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 -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr a
managed
  result <- action ptr
  touchManagedPtr managed
  return 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 Ptr a
forall a. Ptr a
nullPtr
maybeWithManagedPtr (Just a
managed) Ptr a -> IO c
action = a -> (Ptr a -> IO c) -> IO c
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
  ptrs <- (a -> IO (Ptr a)) -> [a] -> IO [Ptr a]
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 a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr [a]
managedList
  result <- action ptrs
  mapM_ touchManagedPtr managedList
  return 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 finishes.
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
  managed <- ManagedPtr a -> a
forall a b. Coercible a b => a -> b
coerce (ManagedPtr a -> a) -> IO (ManagedPtr a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO (ManagedPtr a)
forall a. Ptr a -> IO (ManagedPtr a)
newManagedPtr_ Ptr a
ptr
  r <- action managed
  _ <- disownManagedPtr managed
  return 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 = a -> IO (Ptr a)
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 = a -> ManagedPtr a
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
        ptr :: Ptr b
ptr = (Ptr a -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (Ptr a -> Ptr b)
-> (ManagedPtr a -> Ptr a) -> ManagedPtr a -> Ptr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr a -> Ptr a)
-> (ManagedPtr a -> ForeignPtr a) -> ManagedPtr a -> Ptr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr a -> ForeignPtr a
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr a
c
    disowned <- IORef (Maybe CallStack) -> IO (Maybe CallStack)
forall a. IORef a -> IO a
readIORef (ManagedPtr a -> IORef (Maybe CallStack)
forall a. ManagedPtr a -> IORef (Maybe CallStack)
managedPtrIsDisowned ManagedPtr a
c)
    maybe (return ptr) (notOwnedWarning ptr) 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 <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr a -> String
forall a. Show a => a -> String
show Ptr a
ptr
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">, this may lead to crashes.\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"• Callstack for the unsafe access to the pointer:\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"• The pointer was disowned at:\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
  Ptr a -> IO (Ptr a)
forall a. a -> IO a
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 = a -> ManagedPtr a
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
                    in (ForeignPtr a -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr (ForeignPtr a -> IO ())
-> (ManagedPtr a -> ForeignPtr a) -> ManagedPtr a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr a -> ForeignPtr a
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) = o -> (Ptr o -> IO Bool) -> IO Bool
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO Bool) -> IO Bool) -> (Ptr o -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr o
objPtr -> do
  check <- Ptr o -> CGType -> IO CInt
forall o. Ptr o -> CGType -> IO CInt
c_check_object_type Ptr o
objPtr CGType
cgtype
  return $ check /= 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 <- forall a. TypedObject a => IO GType
glibType @o'
  isInstance <- checkInstanceType obj gtype
  if isInstance
    then return . Just . constructor . coerce $ toManagedPtr obj
    else return 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 <- forall a. TypedObject a => IO GType
glibType @o'
    isInstance <- checkInstanceType obj gtype
    if not isInstance
      then do
      srcType <- glibType @o >>= gtypeName
      destType <- glibType @o' >>= gtypeName
      error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to "
        ++ destType ++ " requested."
      else return (constructor $ coerce $ toManagedPtr 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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
quotedFn
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", this may lead to crashes.\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"• Callstack for the unsafe call to "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
quotedFn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"This is probably a bug in the introspection data,\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"please report it at https://github.com/haskell-gi/haskell-gi/issues")
  where quotedFn :: String
quotedFn = String
"‘" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn String -> String -> String
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr b
ptr Ptr b -> Ptr b -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr b
forall a. Ptr a
nullPtr) (String -> CallStack -> IO ()
nullPtrWarning String
"newObject" CallStack
HasCallStack => CallStack
callStack)
  IO (Ptr b) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr b) -> IO ()) -> IO (Ptr b) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr b -> IO (Ptr b)
forall a. Ptr a -> IO (Ptr a)
g_object_ref_sink Ptr b
ptr
  fPtr <- FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
forall a.
HasCallStack =>
FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' FinalizerPtr a
forall a. FunPtr (Ptr a -> IO ())
ptr_to_g_object_unref (Ptr a -> IO (ManagedPtr a)) -> Ptr a -> IO (ManagedPtr a)
forall a b. (a -> b) -> a -> b
$ Ptr b -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr b
ptr
  return $! constructor fPtr

-- | Perform the given IO action with a wrapped copy of the given ptr
-- to a GObject. Note that this increases the reference count of the
-- wrapped GObject, similarly to 'newObject'.
withNewObject :: (HasCallStack, GObject o)
                  => Ptr o -> (o -> IO b) -> IO b
withNewObject :: forall o b.
(HasCallStack, GObject o) =>
Ptr o -> (o -> IO b) -> IO b
withNewObject Ptr o
ptr o -> IO b
action = do
  IO (Ptr o) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr o) -> IO ()) -> IO (Ptr o) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr o -> IO (Ptr o)
forall a. Ptr a -> IO (Ptr a)
g_object_ref_sink Ptr o
ptr
  managed <- FinalizerPtr Any -> Ptr Any -> IO (ManagedPtr Any)
forall a.
HasCallStack =>
FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' FinalizerPtr Any
forall a. FunPtr (Ptr a -> IO ())
ptr_to_g_object_unref (Ptr Any -> IO (ManagedPtr Any)) -> Ptr Any -> IO (ManagedPtr Any)
forall a b. (a -> b) -> a -> b
$ Ptr o -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr o
ptr
  action (coerce managed)

-- | 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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr b
ptr Ptr b -> Ptr b -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr b
forall a. Ptr a
nullPtr) (String -> CallStack -> IO ()
nullPtrWarning String
"wrapObject" CallStack
HasCallStack => CallStack
callStack)
  fPtr <- FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
forall a.
HasCallStack =>
FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' FinalizerPtr a
forall a. FunPtr (Ptr a -> IO ())
ptr_to_g_object_unref (Ptr a -> IO (ManagedPtr a)) -> Ptr a -> IO (ManagedPtr a)
forall a b. (a -> b) -> a -> b
$ Ptr b -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr b
ptr
  return $! constructor 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 <- a -> IO (Ptr Any)
forall a b. (HasCallStack, GObject a) => a -> IO (Ptr b)
disownObject a
obj
  dbgDealloc obj
  dbg_g_object_unref 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 = a -> (Ptr a -> IO ()) -> IO ()
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
obj ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
  a -> IO ()
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
obj
  Ptr a -> IO ()
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 = a -> (Ptr a -> IO (Ptr b)) -> IO (Ptr b)
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
obj ((Ptr a -> IO (Ptr b)) -> IO (Ptr b))
-> (Ptr a -> IO (Ptr b)) -> IO (Ptr b)
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
  a -> IO ()
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
obj
  Ptr a -> IO ()
forall a. Ptr a -> IO ()
dbg_g_object_disown Ptr a
ptr
  Ptr Any -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (Ptr Any -> Ptr b) -> IO (Ptr Any) -> IO (Ptr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (Ptr Any)
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 gtype <- forall a. TypedObject a => IO GType
glibType @a
  ptr' <- g_boxed_copy gtype ptr
  fPtr <- newManagedPtr ptr' (boxed_free_helper gtype ptr')
  return $! constructor 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 gtype <- forall a. TypedObject a => IO GType
glibType @a
  fPtr <- newManagedPtr ptr (boxed_free_helper gtype ptr)
  return $! constructor 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 gtype <- forall a. TypedObject a => IO GType
glibType @a
  withManagedPtr b (g_boxed_copy 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 gtype <- forall a. TypedObject a => IO GType
glibType @a
  g_boxed_copy gtype 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 gtype <- forall a. TypedObject a => IO GType
glibType @a
  ptr <- disownManagedPtr boxed
  dbgDealloc boxed
  g_boxed_free gtype 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 = a -> IO (Ptr a)
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 = (a -> IO a) -> IO a
forall a. (a -> IO a) -> IO a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((a -> IO a) -> IO a) -> (a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \a
wrapped -> do
  fPtr <- Ptr a -> IO () -> IO (ManagedPtr a)
forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr (a -> IO ()
forall a. BoxedPtr a => a -> IO ()
boxedPtrFree a
wrapped)
  return $! constructor 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
  tmpWrap <- Ptr a -> IO (ManagedPtr a)
forall a. Ptr a -> IO (ManagedPtr a)
newManagedPtr_ Ptr a
ptr
  ptr' <- boxedPtrCopy (constructor tmpWrap)
  return $! 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' <- IO (Ptr a)
forall a. CallocPtr a => IO (Ptr a)
boxedPtrCalloc
  memcpy ptr' ptr size
  return 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
  env <- String -> IO (Maybe String)
lookupEnv String
"HASKELL_GI_DEBUG_MEM"
  case env of
    Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
_ -> do
      let mPtr :: ManagedPtr a
mPtr = a -> ManagedPtr a
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
          ptr :: Ptr a
ptr = (ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr a -> Ptr a)
-> (ManagedPtr a -> ForeignPtr a) -> ManagedPtr a -> Ptr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr a -> ForeignPtr a
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr a
mPtr
      threadPtr <- IO (Ptr ())
g_thread_self
      hPutStrLn stderr ("Releasing <" ++ show ptr ++ "> from thread ["
                         ++ show threadPtr ++ "].\n"
                         ++ (case managedPtrAllocCallStack mPtr of
                               Just CallStack
allocCS -> String
"• Callstack for allocation:\n"
                                               String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
allocCS String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                               Maybe CallStack
Nothing -> String
"")
                         ++ "• CallStack for deallocation:\n"
                         ++ prettyCallStack callStack ++ "\n")