module Data.GI.Base.ManagedPtr
(
newManagedPtr
, newManagedPtr'
, withManagedPtr
, maybeWithManagedPtr
, withManagedPtrList
, unsafeManagedPtrGetPtr
, unsafeManagedPtrCastPtr
, touchManagedPtr
, disownManagedPtr
, castTo
, unsafeCastTo
, newObject
, wrapObject
, 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 Data.Coerce (coerce)
import Data.IORef (newIORef, readIORef, writeIORef, IORef)
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 (HasCallStack, prettyCallStack, callStack)
import Data.GI.Base.Utils
import System.IO (hPutStrLn, stderr)
newManagedPtr :: Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr ptr finalizer = do
let ownedFinalizer :: IORef Bool -> IO ()
ownedFinalizer boolRef = do
owned <- readIORef boolRef
when owned finalizer
isOwnedRef <- newIORef True
fPtr <- FC.newForeignPtr ptr (ownedFinalizer isOwnedRef)
return $ ManagedPtr {
managedForeignPtr = fPtr
, managedPtrIsOwned = isOwnedRef
}
foreign import ccall "dynamic"
mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()
newManagedPtr' :: FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' finalizer ptr = newManagedPtr ptr (mkFinalizer finalizer ptr)
newManagedPtr_ :: Ptr a -> IO (ManagedPtr a)
newManagedPtr_ ptr = do
isOwnedRef <- newIORef True
fPtr <- newForeignPtr_ ptr
return $ ManagedPtr {
managedForeignPtr = fPtr
, managedPtrIsOwned = isOwnedRef
}
disownManagedPtr :: forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
disownManagedPtr managed = do
ptr <- unsafeManagedPtrGetPtr managed
writeIORef (managedPtrIsOwned c) False
return ptr
where c = coerce managed :: ManagedPtr ()
withManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> (Ptr a -> IO c) -> IO c
withManagedPtr managed action = do
ptr <- unsafeManagedPtrGetPtr managed
result <- action ptr
touchManagedPtr managed
return result
maybeWithManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => Maybe a -> (Ptr a -> IO c) -> IO c
maybeWithManagedPtr Nothing action = action nullPtr
maybeWithManagedPtr (Just managed) action = do
ptr <- unsafeManagedPtrGetPtr managed
result <- action ptr
touchManagedPtr managed
return result
withManagedPtrList :: (HasCallStack, ManagedPtrNewtype a) => [a] -> ([Ptr a] -> IO c) -> IO c
withManagedPtrList managedList action = do
ptrs <- mapM unsafeManagedPtrGetPtr managedList
result <- action ptrs
mapM_ touchManagedPtr managedList
return result
unsafeManagedPtrGetPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr = unsafeManagedPtrCastPtr
unsafeManagedPtrCastPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) =>
a -> IO (Ptr b)
unsafeManagedPtrCastPtr m = do
let c = coerce m :: ManagedPtr ()
ptr = (castPtr . unsafeForeignPtrToPtr . managedForeignPtr) c
owned <- readIORef (managedPtrIsOwned c)
when (not owned) (notOwnedWarning ptr)
return ptr
notOwnedWarning :: HasCallStack => Ptr a -> IO ()
notOwnedWarning ptr = do
hPutStrLn stderr ("Accessing a disowned pointer <" ++ show ptr
++ ">, this may lead to crashes.\n"
++ prettyCallStack callStack)
touchManagedPtr :: forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr m = let c = coerce m :: ManagedPtr ()
in (touchForeignPtr . managedForeignPtr) c
foreign import ccall unsafe "check_object_type"
c_check_object_type :: Ptr o -> CGType -> CInt
castTo :: forall o o'. (GObject o, GObject o') =>
(ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo constructor obj =
withManagedPtr obj $ \objPtr -> do
GType t <- gobjectType (undefined :: o')
if c_check_object_type objPtr t /= 1
then return Nothing
else Just <$> newObject constructor objPtr
unsafeCastTo :: forall o o'. (HasCallStack, GObject o, GObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo constructor obj =
withManagedPtr obj $ \objPtr -> do
GType t <- gobjectType (undefined :: o')
if c_check_object_type objPtr t /= 1
then do
srcType <- gobjectType obj >>= gtypeName
destType <- gobjectType (undefined :: o') >>= gtypeName
error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to "
++ destType ++ " requested."
else newObject constructor objPtr
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)
newObject :: (GObject a, GObject b) => (ManagedPtr a -> a) -> Ptr b -> IO a
newObject constructor ptr = do
void $ g_object_ref_sink ptr
fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr
return $! constructor fPtr
wrapObject :: forall a b. (GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
wrapObject constructor ptr = do
fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr
return $! constructor fPtr
foreign import ccall "dbg_g_object_unref"
dbg_g_object_unref :: Ptr a -> IO ()
unrefObject :: GObject a => a -> IO ()
unrefObject obj = withManagedPtr obj dbg_g_object_unref
foreign import ccall "dbg_g_object_disown"
dbg_g_object_disown :: Ptr a -> IO ()
disownObject :: GObject a => a -> IO (Ptr b)
disownObject obj = withManagedPtr obj $ \ptr -> do
dbg_g_object_disown ptr
castPtr <$> disownManagedPtr obj
foreign import ccall "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. BoxedObject a => (ManagedPtr a -> a) -> Ptr a -> IO a
newBoxed constructor ptr = do
GType gtype <- boxedType (undefined :: a)
ptr' <- g_boxed_copy gtype ptr
fPtr <- newManagedPtr ptr' (boxed_free_helper gtype ptr')
return $! constructor fPtr
wrapBoxed :: forall a. BoxedObject a => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed constructor ptr = do
GType gtype <- boxedType (undefined :: a)
fPtr <- newManagedPtr ptr (boxed_free_helper gtype ptr)
return $! constructor fPtr
copyBoxed :: forall a. BoxedObject a => a -> IO (Ptr a)
copyBoxed b = do
GType gtype <- boxedType b
withManagedPtr b (g_boxed_copy gtype)
copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a)
copyBoxedPtr ptr = do
GType gtype <- boxedType (undefined :: a)
g_boxed_copy gtype ptr
foreign import ccall "g_boxed_free" g_boxed_free ::
CGType -> Ptr a -> IO ()
freeBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO ()
freeBoxed boxed = do
GType gtype <- boxedType (undefined :: a)
ptr <- unsafeManagedPtrGetPtr boxed
g_boxed_free gtype ptr
touchManagedPtr boxed
disownBoxed :: BoxedObject a => a -> IO (Ptr a)
disownBoxed = disownManagedPtr
wrapPtr :: WrappedPtr a => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapPtr constructor ptr = do
fPtr <- case wrappedPtrFree of
Nothing -> newManagedPtr_ ptr
Just finalizer -> newManagedPtr' finalizer ptr
return $! constructor fPtr
newPtr :: WrappedPtr a => (ManagedPtr a -> a) -> Ptr a -> IO a
newPtr constructor ptr = do
tmpWrap <- newManagedPtr_ ptr
ptr' <- wrappedPtrCopy (constructor tmpWrap)
return $! ptr'
copyBytes :: WrappedPtr a => Int -> Ptr a -> IO (Ptr a)
copyBytes size ptr = do
ptr' <- wrappedPtrCalloc
memcpy ptr' ptr size
return ptr'