module Data.GI.Base.ManagedPtr
(
withManagedPtr
, maybeWithManagedPtr
, withManagedPtrList
, unsafeManagedPtrGetPtr
, unsafeManagedPtrCastPtr
, touchManagedPtr
, castTo
, unsafeCastTo
, newObject
, wrapObject
, refObject
, unrefObject
, newBoxed
, wrapBoxed
, copyBoxed
, copyBoxedPtr
, freeBoxed
, wrapPtr
, newPtr
, copyPtr
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (when, void)
import Data.Coerce (coerce)
import Foreign (poke)
import Foreign.C (CInt(..))
import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr)
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtrEnv,
touchForeignPtr, newForeignPtr_)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Data.GI.Base.BasicTypes
import Data.GI.Base.Utils
#if MIN_VERSION_base(4,9,0)
import GHC.Stack (HasCallStack)
#elif MIN_VERSION_base(4,8,0)
import GHC.Stack (CallStack)
import GHC.Exts (Constraint)
type HasCallStack = ((?callStack :: CallStack) :: Constraint)
#else
import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
#endif
withManagedPtr :: ForeignPtrNewtype a => a -> (Ptr a -> IO c) -> IO c
withManagedPtr managed action = do
let ptr = unsafeManagedPtrGetPtr managed
result <- action ptr
touchManagedPtr managed
return result
maybeWithManagedPtr :: ForeignPtrNewtype a => Maybe a -> (Ptr a -> IO c) -> IO c
maybeWithManagedPtr Nothing action = action nullPtr
maybeWithManagedPtr (Just managed) action = do
let ptr = unsafeManagedPtrGetPtr managed
result <- action ptr
touchManagedPtr managed
return result
withManagedPtrList :: ForeignPtrNewtype a => [a] -> ([Ptr a] -> IO c) -> IO c
withManagedPtrList managedList action = do
let ptrs = map unsafeManagedPtrGetPtr managedList
result <- action ptrs
mapM_ touchManagedPtr managedList
return result
unsafeManagedPtrGetPtr :: ForeignPtrNewtype a => a -> Ptr a
unsafeManagedPtrGetPtr = unsafeManagedPtrCastPtr
unsafeManagedPtrCastPtr :: forall a b. ForeignPtrNewtype a => a -> Ptr b
unsafeManagedPtrCastPtr x = let p = coerce x :: ForeignPtr ()
in castPtr (unsafeForeignPtrToPtr p)
touchManagedPtr :: forall a. ForeignPtrNewtype a => a -> IO ()
touchManagedPtr x = let p = coerce x :: ForeignPtr ()
in touchForeignPtr p
foreign import ccall unsafe "check_object_type"
c_check_object_type :: Ptr o -> CGType -> CInt
castTo :: forall o o'. (GObject o, GObject o') =>
(ForeignPtr 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') =>
(ForeignPtr 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" g_object_ref ::
Ptr a -> IO (Ptr a)
newObject :: (GObject a, GObject b) => (ForeignPtr a -> a) -> Ptr b -> IO a
newObject constructor ptr = do
void $ g_object_ref ptr
fPtr <- newForeignPtr ptr_to_g_object_unref $ castPtr ptr
return $! constructor fPtr
foreign import ccall "g_object_ref_sink" g_object_ref_sink ::
Ptr a -> IO (Ptr a)
wrapObject :: forall a b. (GObject a, GObject b) =>
(ForeignPtr a -> a) -> Ptr b -> IO a
wrapObject constructor ptr = do
when (gobjectIsInitiallyUnowned (undefined :: a)) $
void $ g_object_ref_sink ptr
fPtr <- newForeignPtr ptr_to_g_object_unref $ castPtr ptr
return $! constructor fPtr
refObject :: (GObject a, GObject b) => a -> IO (Ptr b)
refObject obj = castPtr <$> withManagedPtr obj g_object_ref
foreign import ccall "g_object_unref" g_object_unref ::
Ptr a -> IO ()
unrefObject :: GObject a => a -> IO ()
unrefObject obj = withManagedPtr obj g_object_unref
foreign import ccall "& boxed_free_helper" boxed_free_helper ::
FunPtr (Ptr env -> Ptr a -> IO ())
foreign import ccall "g_boxed_copy" g_boxed_copy ::
CGType -> Ptr a -> IO (Ptr a)
newBoxed :: forall a. BoxedObject a => (ForeignPtr a -> a) -> Ptr a -> IO a
newBoxed constructor ptr = do
GType gtype <- boxedType (undefined :: a)
env <- allocMem :: IO (Ptr CGType)
poke env gtype
ptr' <- g_boxed_copy gtype ptr
fPtr <- newForeignPtrEnv boxed_free_helper env ptr'
return $! constructor fPtr
wrapBoxed :: forall a. BoxedObject a => (ForeignPtr a -> a) -> Ptr a -> IO a
wrapBoxed constructor ptr = do
GType gtype <- boxedType (undefined :: a)
env <- allocMem :: IO (Ptr CGType)
poke env gtype
fPtr <- newForeignPtrEnv boxed_free_helper env ptr
return $! constructor fPtr
copyBoxed :: forall a. BoxedObject a => a -> IO (Ptr a)
copyBoxed boxed = withManagedPtr boxed copyBoxedPtr
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. BoxedObject a => a -> IO ()
freeBoxed boxed = do
GType gtype <- boxedType (undefined :: a)
let ptr = unsafeManagedPtrGetPtr boxed
g_boxed_free gtype ptr
touchManagedPtr boxed
wrapPtr :: WrappedPtr a => (ForeignPtr a -> a) -> Ptr a -> IO a
wrapPtr constructor ptr = do
fPtr <- case wrappedPtrFree of
Nothing -> newForeignPtr_ ptr
Just finalizer -> newForeignPtr finalizer ptr
return $! constructor fPtr
newPtr :: WrappedPtr a => (ForeignPtr a -> a) -> Ptr a -> IO a
newPtr constructor ptr = do
ptr' <- wrappedPtrCopy ptr
fPtr <- case wrappedPtrFree of
Nothing -> newForeignPtr_ ptr
Just finalizer -> newForeignPtr finalizer ptr'
return $! constructor fPtr
copyPtr :: WrappedPtr a => Int -> Ptr a -> IO (Ptr a)
copyPtr size ptr = do
ptr' <- wrappedPtrCalloc
memcpy ptr' ptr size
return ptr'