module Data.GI.Base.ManagedPtr
(
withManagedPtr
, withManagedPtrList
, unsafeManagedPtrGetPtr
, unsafeManagedPtrCastPtr
, touchManagedPtr
, castTo
, unsafeCastTo
, newObject
, wrapObject
, refObject
, unrefObject
, newBoxed
, wrapBoxed
, copyBoxed
, copyBoxedPtr
, freeBoxed
, wrapPtr
, newPtr
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (when, void)
import Data.Coerce (coerce)
import Foreign (finalizerFree, poke)
import Foreign.C (CInt(..))
import Foreign.Ptr (Ptr, FunPtr, castPtr)
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtrEnv, touchForeignPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Data.GI.Base.BasicTypes
import Data.GI.Base.Utils
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
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'. (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 :: (ForeignPtr a -> a) -> Ptr a -> IO a
wrapPtr constructor ptr = do
fPtr <- newForeignPtr finalizerFree ptr
return $! constructor fPtr
newPtr :: Int -> (ForeignPtr a -> a) -> Ptr a -> IO a
newPtr n constructor ptr = do
ptr' <- callocBytes n :: IO (Ptr a)
memcpy ptr' ptr n
fPtr <- newForeignPtr finalizerFree ptr'
return $! constructor fPtr