{-# 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
    , 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 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 :: Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr ptr :: Ptr a
ptr finalizer :: IO ()
finalizer = do
  IORef (Maybe CallStack)
isDisownedRef <- Maybe CallStack -> IO (IORef (Maybe CallStack))
forall a. a -> IO (IORef a)
newIORef Maybe CallStack
forall a. Maybe a
Nothing
  Bool
dbgMode <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "HASKELL_GI_DEBUG_MEM"
  let dbgCallStack :: Maybe CallStack
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
  ForeignPtr a
fPtr <- Ptr a -> IO () -> IO (ForeignPtr a)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
FC.newForeignPtr Ptr a
ptr (IO ()
-> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack) -> IO ()
forall a.
IO ()
-> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack) -> IO ()
ownedFinalizer IO ()
finalizer Ptr a
ptr Maybe CallStack
dbgCallStack IORef (Maybe CallStack)
isDisownedRef)
  ManagedPtr a -> IO (ManagedPtr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ManagedPtr a -> IO (ManagedPtr a))
-> ManagedPtr a -> IO (ManagedPtr a)
forall a b. (a -> b) -> a -> b
$ ManagedPtr :: forall a.
ForeignPtr a
-> Maybe CallStack -> IORef (Maybe CallStack) -> ManagedPtr a
ManagedPtr {
               managedForeignPtr :: ForeignPtr a
managedForeignPtr = ForeignPtr a
fPtr
             , managedPtrAllocCallStack :: Maybe CallStack
managedPtrAllocCallStack = Maybe CallStack
dbgCallStack
             , managedPtrIsDisowned :: IORef (Maybe CallStack)
managedPtrIsDisowned = IORef (Maybe CallStack)
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 :: IO ()
-> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack) -> IO ()
ownedFinalizer finalizer :: IO ()
finalizer ptr :: Ptr a
ptr allocCallStack :: Maybe CallStack
allocCallStack callStackRef :: IORef (Maybe CallStack)
callStackRef = do
  Maybe CallStack
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.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe CallStack -> Bool
forall a. Maybe a -> Bool
isNothing Maybe CallStack
cs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> (CallStack -> IO ()) -> Maybe CallStack -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Ptr a -> CallStack -> IO ()
forall a. Ptr a -> CallStack -> IO ()
printAllocDebug Ptr a
ptr) Maybe CallStack
allocCallStack
    IO ()
finalizer

-- | Print some debug diagnostics for an allocation.
printAllocDebug :: Ptr a -> CallStack -> IO ()
printAllocDebug :: Ptr a -> CallStack -> IO ()
printAllocDebug ptr :: Ptr a
ptr allocCS :: 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) ("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
forall a. Semigroup a => a -> a -> a
<> "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
<> "\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' :: FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' finalizer :: FinalizerPtr a
finalizer ptr :: 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_ :: Ptr a -> IO (ManagedPtr a)
newManagedPtr_ ptr :: Ptr a
ptr = do
  IORef (Maybe CallStack)
isDisownedRef <- Maybe CallStack -> IO (IORef (Maybe CallStack))
forall a. a -> IO (IORef a)
newIORef Maybe CallStack
forall a. Maybe a
Nothing
  ForeignPtr a
fPtr <- Ptr a -> IO (ForeignPtr a)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr a
ptr
  ManagedPtr a -> IO (ManagedPtr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ManagedPtr a -> IO (ManagedPtr a))
-> ManagedPtr a -> IO (ManagedPtr a)
forall a b. (a -> b) -> a -> b
$ ManagedPtr :: forall a.
ForeignPtr a
-> Maybe CallStack -> IORef (Maybe CallStack) -> ManagedPtr a
ManagedPtr {
               managedForeignPtr :: ForeignPtr a
managedForeignPtr = ForeignPtr a
fPtr
             , managedPtrAllocCallStack :: Maybe CallStack
managedPtrAllocCallStack = Maybe CallStack
forall a. Maybe a
Nothing
             , managedPtrIsDisowned :: IORef (Maybe CallStack)
managedPtrIsDisowned = IORef (Maybe CallStack)
isDisownedRef
             }

-- | Do not run the finalizers upon garbage collection of the
-- `ManagedPtr`.
disownManagedPtr :: forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
disownManagedPtr :: a -> IO (Ptr a)
disownManagedPtr managed :: a
managed = do
  Ptr a
ptr <- a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr a
managed
  IORef (Maybe CallStack) -> Maybe CallStack -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ManagedPtr () -> IORef (Maybe CallStack)
forall a. ManagedPtr a -> IORef (Maybe CallStack)
managedPtrIsDisowned ManagedPtr ()
c) (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack)
  Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr
    where c :: ManagedPtr ()
c = a -> ManagedPtr ()
forall a b. Coercible a b => a -> b
coerce a
managed :: ManagedPtr ()

-- | Perform an IO action on the 'Ptr' inside a managed pointer.
withManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> (Ptr a -> IO c) -> IO c
withManagedPtr :: a -> (Ptr a -> IO c) -> IO c
withManagedPtr managed :: a
managed action :: Ptr a -> IO c
action = do
  Ptr a
ptr <- a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr a
managed
  c
result <- Ptr a -> IO c
action Ptr a
ptr
  a -> IO ()
forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr a
managed
  c -> IO c
forall (m :: * -> *) a. Monad m => a -> m a
return c
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 :: Maybe a -> (Ptr a -> IO c) -> IO c
maybeWithManagedPtr Nothing action :: Ptr a -> IO c
action = Ptr a -> IO c
action Ptr a
forall a. Ptr a
nullPtr
maybeWithManagedPtr (Just managed :: a
managed) action :: 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 :: [a] -> ([Ptr a] -> IO c) -> IO c
withManagedPtrList managedList :: [a]
managedList action :: [Ptr a] -> IO c
action = do
  [Ptr a]
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)
mapM a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
unsafeManagedPtrGetPtr [a]
managedList
  c
result <- [Ptr a] -> IO c
action [Ptr a]
ptrs
  (a -> IO ()) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> IO ()
forall a. ManagedPtrNewtype a => a -> IO ()
touchManagedPtr [a]
managedList
  c -> IO c
forall (m :: * -> *) a. Monad m => a -> m a
return c
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 finished.
withTransient :: (HasCallStack, ManagedPtrNewtype a)
              => (ManagedPtr a -> a) -> Ptr a -> (a -> IO b) -> IO b
withTransient :: (ManagedPtr a -> a) -> Ptr a -> (a -> IO b) -> IO b
withTransient constructor :: ManagedPtr a -> a
constructor ptr :: Ptr a
ptr action :: a -> IO b
action = do
  a
managed <- ManagedPtr a -> a
constructor (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
  b
r <- a -> IO b
action a
managed
  Ptr a
_ <- a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
disownManagedPtr a
managed
  b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
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 :: 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 :: a -> IO (Ptr b)
unsafeManagedPtrCastPtr m :: a
m = do
    let c :: ManagedPtr ()
c = a -> ManagedPtr ()
forall a b. Coercible a b => a -> b
coerce a
m :: ManagedPtr ()
        ptr :: Ptr b
ptr = (Ptr () -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (Ptr () -> Ptr b)
-> (ManagedPtr () -> Ptr ()) -> ManagedPtr () -> Ptr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr () -> Ptr ()
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr () -> Ptr ())
-> (ManagedPtr () -> ForeignPtr ()) -> ManagedPtr () -> Ptr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr () -> ForeignPtr ()
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr ()
c
    Maybe CallStack
disowned <- IORef (Maybe CallStack) -> IO (Maybe CallStack)
forall a. IORef a -> IO a
readIORef (ManagedPtr () -> IORef (Maybe CallStack)
forall a. ManagedPtr a -> IORef (Maybe CallStack)
managedPtrIsDisowned ManagedPtr ()
c)
    IO (Ptr b)
-> (CallStack -> IO (Ptr b)) -> Maybe CallStack -> IO (Ptr b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ptr b -> IO (Ptr b)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr b
ptr) (Ptr b -> CallStack -> IO (Ptr b)
forall a. HasCallStack => Ptr a -> CallStack -> IO (Ptr a)
notOwnedWarning Ptr b
ptr) Maybe CallStack
disowned

-- | Print a warning when we try to access a disowned foreign ptr.
notOwnedWarning :: HasCallStack => Ptr a -> CallStack -> IO (Ptr a)
notOwnedWarning :: Ptr a -> CallStack -> IO (Ptr a)
notOwnedWarning ptr :: Ptr a
ptr cs :: CallStack
cs = do
  Handle -> String -> IO ()
hPutStrLn Handle
stderr ("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]
++ ">, this may lead to crashes.\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ "• 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]
++ "\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ "• 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]
++ "\n")
  Ptr a -> IO (Ptr 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 :: a -> IO ()
touchManagedPtr m :: a
m = let c :: ManagedPtr ()
c = a -> ManagedPtr ()
forall a b. Coercible a b => a -> b
coerce a
m :: ManagedPtr ()
                    in (ForeignPtr () -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr (ForeignPtr () -> IO ())
-> (ManagedPtr () -> ForeignPtr ()) -> ManagedPtr () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr () -> ForeignPtr ()
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr ()
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 :: GObject o => o -> GType -> IO Bool
checkInstanceType :: o -> GType -> IO Bool
checkInstanceType obj :: o
obj (GType cgtype :: 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
$ \objPtr :: Ptr o
objPtr -> do
  CInt
check <- Ptr o -> CGType -> IO CInt
forall o. Ptr o -> CGType -> IO CInt
c_check_object_type Ptr o
objPtr CGType
cgtype
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CInt
check CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0

-- | Cast to the given type, checking that the cast is valid. If it is
-- not, we return `Nothing`. Usage:
--
-- > maybeWidget <- castTo Widget label
castTo :: forall o o'. (GObject o, GObject o') =>
          (ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo :: (ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo constructor :: ManagedPtr o' -> o'
constructor obj :: o
obj = o -> (Ptr o -> IO (Maybe o')) -> IO (Maybe o')
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO (Maybe o')) -> IO (Maybe o'))
-> (Ptr o -> IO (Maybe o')) -> IO (Maybe o')
forall a b. (a -> b) -> a -> b
$ \objPtr :: Ptr o
objPtr -> do
  GType
gtype <- GObject o' => IO GType
forall a. GObject a => IO GType
gobjectType @o'
  Bool
isInstance <- o -> GType -> IO Bool
forall o. GObject o => o -> GType -> IO Bool
checkInstanceType o
obj GType
gtype
  if Bool
isInstance
    then o' -> Maybe o'
forall a. a -> Maybe a
Just (o' -> Maybe o') -> IO o' -> IO (Maybe o')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ManagedPtr o' -> o') -> Ptr o -> IO o'
forall a b.
(HasCallStack, GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
newObject ManagedPtr o' -> o'
constructor Ptr o
objPtr
    else Maybe o' -> IO (Maybe o')
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe o'
forall a. Maybe a
Nothing

-- | Cast to the given type, assuming that the cast will succeed. This
-- function will call `error` if the cast is illegal.
unsafeCastTo :: forall o o'. (HasCallStack, GObject o, GObject o') =>
                (ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo :: (ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo constructor :: ManagedPtr o' -> o'
constructor obj :: o
obj =
  o -> (Ptr o -> IO o') -> IO o'
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr o
obj ((Ptr o -> IO o') -> IO o') -> (Ptr o -> IO o') -> IO o'
forall a b. (a -> b) -> a -> b
$ \objPtr :: Ptr o
objPtr -> do
    GType
gtype <- GObject o' => IO GType
forall a. GObject a => IO GType
gobjectType @o'
    Bool
isInstance <- o -> GType -> IO Bool
forall o. GObject o => o -> GType -> IO Bool
checkInstanceType o
obj GType
gtype
    if Bool -> Bool
not Bool
isInstance
      then do
      String
srcType <- GObject o => IO GType
forall a. GObject a => IO GType
gobjectType @o IO GType -> (GType -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GType -> IO String
gtypeName
      String
destType <- GObject o' => IO GType
forall a. GObject a => IO GType
gobjectType @o' IO GType -> (GType -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GType -> IO String
gtypeName
      String -> IO o'
forall a. HasCallStack => String -> a
error (String -> IO o') -> String -> IO o'
forall a b. (a -> b) -> a -> b
$ "unsafeCastTo :: invalid conversion from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcType String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destType String -> String -> String
forall a. [a] -> [a] -> [a]
++ " requested."
      else (ManagedPtr o' -> o') -> Ptr o -> IO o'
forall a b.
(HasCallStack, GObject a, GObject b) =>
(ManagedPtr a -> a) -> Ptr b -> IO a
newObject ManagedPtr o' -> o'
constructor Ptr o
objPtr

-- 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 fn :: String
fn cs :: CallStack
cs =
  Handle -> String -> IO ()
hPutStrLn Handle
stderr ("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]
++ ", this may lead to crashes.\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ "• Callstack for the unsafe call to "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
quotedFn String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ "This is probably a bug in the introspection data,\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ "please report it at https://github.com/haskell-gi/haskell-gi/issues")
  where quotedFn :: String
quotedFn = "‘" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ "’"

-- | 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 :: (ManagedPtr a -> a) -> Ptr b -> IO a
newObject constructor :: ManagedPtr a -> a
constructor ptr :: 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 "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
  ManagedPtr a
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
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | 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 :: (ManagedPtr a -> a) -> Ptr b -> IO a
wrapObject constructor :: ManagedPtr a -> a
constructor ptr :: 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 "wrapObject" CallStack
HasCallStack => CallStack
callStack)
  ManagedPtr a
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
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
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 :: a -> IO ()
releaseObject obj :: a
obj = do
  Ptr Any
ptr <- a -> IO (Ptr Any)
forall a b. (HasCallStack, GObject a) => a -> IO (Ptr b)
disownObject a
obj
  a -> IO ()
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
obj
  Ptr Any -> IO ()
forall a. Ptr a -> IO ()
dbg_g_object_unref Ptr Any
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 :: a -> IO ()
unrefObject obj :: 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 :: 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 :: a -> IO (Ptr b)
disownObject obj :: 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 :: 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 a -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (Ptr a -> Ptr b) -> IO (Ptr a) -> IO (Ptr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
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, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a
newBoxed :: (ManagedPtr a -> a) -> Ptr a -> IO a
newBoxed constructor :: ManagedPtr a -> a
constructor ptr :: Ptr a
ptr = do
  GType gtype :: CGType
gtype <- a -> IO GType
forall a. BoxedObject a => a -> IO GType
boxedType (a
forall a. HasCallStack => a
undefined :: a)
  Ptr a
ptr' <- CGType -> Ptr a -> IO (Ptr a)
forall a. CGType -> Ptr a -> IO (Ptr a)
g_boxed_copy CGType
gtype Ptr a
ptr
  ManagedPtr a
fPtr <- Ptr a -> IO () -> IO (ManagedPtr a)
forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr' (CGType -> Ptr a -> IO ()
forall a. CGType -> Ptr a -> IO ()
boxed_free_helper CGType
gtype Ptr a
ptr')
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
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, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed :: (ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed constructor :: ManagedPtr a -> a
constructor ptr :: Ptr a
ptr = do
  GType gtype :: CGType
gtype <- a -> IO GType
forall a. BoxedObject a => a -> IO GType
boxedType (a
forall a. HasCallStack => a
undefined :: a)
  ManagedPtr a
fPtr <- Ptr a -> IO () -> IO (ManagedPtr a)
forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr (CGType -> Ptr a -> IO ()
forall a. CGType -> Ptr a -> IO ()
boxed_free_helper CGType
gtype Ptr a
ptr)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | Make a copy of the given boxed object.
copyBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO (Ptr a)
copyBoxed :: a -> IO (Ptr a)
copyBoxed b :: a
b = do
  GType gtype :: CGType
gtype <- a -> IO GType
forall a. BoxedObject a => a -> IO GType
boxedType a
b
  a -> (Ptr a -> IO (Ptr a)) -> IO (Ptr a)
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr a
b (CGType -> Ptr a -> IO (Ptr a)
forall a. CGType -> Ptr a -> IO (Ptr a)
g_boxed_copy CGType
gtype)

-- | Like 'copyBoxed', but acting directly on a pointer, instead of a
-- managed pointer.
copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a)
copyBoxedPtr :: Ptr a -> IO (Ptr a)
copyBoxedPtr ptr :: Ptr a
ptr = do
  GType gtype :: CGType
gtype <- a -> IO GType
forall a. BoxedObject a => a -> IO GType
boxedType (a
forall a. HasCallStack => a
undefined :: a)
  CGType -> Ptr a -> IO (Ptr 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 ()

-- | Free the memory associated with a boxed object. Note that this
-- disowns the associated `ManagedPtr` via `disownManagedPtr`.
freeBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO ()
freeBoxed :: a -> IO ()
freeBoxed boxed :: a
boxed = do
  GType gtype :: CGType
gtype <- a -> IO GType
forall a. BoxedObject a => a -> IO GType
boxedType (a
forall a. HasCallStack => a
undefined :: a)
  Ptr a
ptr <- a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
disownManagedPtr a
boxed
  a -> IO ()
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
boxed
  CGType -> Ptr a -> IO ()
forall a. CGType -> Ptr a -> IO ()
g_boxed_free CGType
gtype Ptr a
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 `BoxedObject`.
disownBoxed :: (HasCallStack, BoxedObject a) => a -> IO (Ptr a)
disownBoxed :: a -> IO (Ptr a)
disownBoxed = a -> IO (Ptr a)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
disownManagedPtr

-- | Wrap a pointer, taking ownership of it.
wrapPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapPtr :: (ManagedPtr a -> a) -> Ptr a -> IO a
wrapPtr constructor :: ManagedPtr a -> a
constructor ptr :: Ptr a
ptr = do
  ManagedPtr a
fPtr <- case Maybe (GDestroyNotify a)
forall a. WrappedPtr a => Maybe (GDestroyNotify a)
wrappedPtrFree of
            Nothing -> Ptr a -> IO (ManagedPtr a)
forall a. Ptr a -> IO (ManagedPtr a)
newManagedPtr_ Ptr a
ptr
            Just finalizer :: GDestroyNotify a
finalizer -> GDestroyNotify a -> Ptr a -> IO (ManagedPtr a)
forall a.
HasCallStack =>
FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)
newManagedPtr' GDestroyNotify a
finalizer Ptr a
ptr
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! ManagedPtr a -> a
constructor ManagedPtr a
fPtr

-- | Wrap a pointer, making a copy of the data.
newPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a
newPtr :: (ManagedPtr a -> a) -> Ptr a -> IO a
newPtr constructor :: ManagedPtr a -> a
constructor ptr :: Ptr a
ptr = do
  ManagedPtr a
tmpWrap <- Ptr a -> IO (ManagedPtr a)
forall a. Ptr a -> IO (ManagedPtr a)
newManagedPtr_ Ptr a
ptr
  a
ptr' <- a -> IO a
forall a. WrappedPtr a => a -> IO a
wrappedPtrCopy (ManagedPtr a -> a
constructor ManagedPtr a
tmpWrap)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! a
ptr'

-- | Make a copy of a wrapped pointer using @memcpy@ into a freshly
-- allocated memory region of the given size.
copyBytes :: WrappedPtr a => Int -> Ptr a -> IO (Ptr a)
copyBytes :: Int -> Ptr a -> IO (Ptr a)
copyBytes size :: Int
size ptr :: Ptr a
ptr = do
  Ptr a
ptr' <- IO (Ptr a)
forall a. WrappedPtr a => IO (Ptr a)
wrappedPtrCalloc
  Ptr a -> Ptr a -> Int -> IO ()
forall a b. Ptr a -> Ptr b -> Int -> IO ()
memcpy Ptr a
ptr' Ptr a
ptr Int
size
  Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr'

foreign import ccall unsafe "g_thread_self" g_thread_self :: IO (Ptr ())

-- | Print a debug message for deallocs if the @HASKELL_GI_DEBUG_MEM@
-- environment variable has been set.
dbgDealloc :: (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc :: a -> IO ()
dbgDealloc m :: a
m = do
  Maybe String
env <- String -> IO (Maybe String)
lookupEnv "HASKELL_GI_DEBUG_MEM"
  case Maybe String
env of
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just _ -> do
      let mPtr :: ManagedPtr ()
mPtr = a -> ManagedPtr ()
forall a b. Coercible a b => a -> b
coerce a
m :: ManagedPtr ()
          ptr :: Ptr ()
ptr = (ForeignPtr () -> Ptr ()
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr () -> Ptr ())
-> (ManagedPtr () -> ForeignPtr ()) -> ManagedPtr () -> Ptr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr () -> ForeignPtr ()
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr ()
mPtr
      Ptr ()
threadPtr <- IO (Ptr ())
g_thread_self
      Handle -> String -> IO ()
hPutStrLn Handle
stderr ("Releasing <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr () -> String
forall a. Show a => a -> String
show Ptr ()
ptr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "> from thread ["
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr () -> String
forall a. Show a => a -> String
show Ptr ()
threadPtr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "].\n"
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ (case ManagedPtr () -> Maybe CallStack
forall a. ManagedPtr a -> Maybe CallStack
managedPtrAllocCallStack ManagedPtr ()
mPtr of
                               Just allocCS :: CallStack
allocCS -> "• 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]
++ "\n\n"
                               Nothing -> "")
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ "• CallStack for deallocation:\n"
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n")