{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
{-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-}
{-# LANGUAGE TypeApplications #-}
module Data.GI.Base.ManagedPtr
(
newManagedPtr
, newManagedPtr'
, newManagedPtr_
, withManagedPtr
, maybeWithManagedPtr
, withManagedPtrList
, withTransient
, unsafeManagedPtrGetPtr
, unsafeManagedPtrCastPtr
, touchManagedPtr
, disownManagedPtr
, castTo
, unsafeCastTo
, checkInstanceType
, 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)
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
}
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
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
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 ()
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)
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
}
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
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
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
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
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
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
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
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
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
foreign import ccall unsafe "check_object_type"
c_check_object_type :: Ptr o -> CGType -> IO CInt
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
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
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)
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)
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
"’"
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
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
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
foreign import ccall unsafe "dbg_g_object_unref"
dbg_g_object_unref :: Ptr a -> IO ()
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
foreign import ccall "dbg_g_object_disown"
dbg_g_object_disown :: Ptr a -> IO ()
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
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)
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
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
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)
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 ()
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
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
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
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'
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 ())
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")