{-# 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 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)

-- | Thin wrapper over `Foreign.Concurrent.newForeignPtr`.
newManagedPtr :: HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr :: Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr 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 String
"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 IO ()
finalizer Ptr a
ptr Maybe CallStack
allocCallStack 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 a
ptr 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) (String
"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 -> String
forall a. Semigroup a => a -> a -> a
<> String
"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
<> String
"\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' FinalizerPtr a
finalizer 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 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 b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr :: a -> IO (Ptr b)
disownManagedPtr 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 a -> IORef (Maybe CallStack)
forall a. ManagedPtr a -> IORef (Maybe CallStack)
managedPtrIsDisowned ManagedPtr a
c) (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack)
  Ptr b -> IO (Ptr b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr a -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr)
    where c :: ManagedPtr a
c = a -> ManagedPtr a
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
managed

-- | 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 a
managed 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 Maybe a
Nothing Ptr a -> IO c
action = Ptr a -> IO c
action Ptr a
forall a. Ptr a
nullPtr
maybeWithManagedPtr (Just a
managed) 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 [a]
managedList [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 ManagedPtr a -> a
constructor Ptr a
ptr 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 Any
_ <- a -> IO (Ptr Any)
forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
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 a
m = do
    let c :: ManagedPtr a
c = a -> ManagedPtr a
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
        ptr :: Ptr b
ptr = (Ptr a -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (Ptr a -> Ptr b)
-> (ManagedPtr a -> Ptr a) -> ManagedPtr a -> Ptr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr a -> Ptr a)
-> (ManagedPtr a -> ForeignPtr a) -> ManagedPtr a -> Ptr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr a -> ForeignPtr a
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr a
c
    Maybe CallStack
disowned <- IORef (Maybe CallStack) -> IO (Maybe CallStack)
forall a. IORef a -> IO a
readIORef (ManagedPtr a -> IORef (Maybe CallStack)
forall a. ManagedPtr a -> IORef (Maybe CallStack)
managedPtrIsDisowned ManagedPtr a
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 a
ptr CallStack
cs = do
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"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]
++ String
">, this may lead to crashes.\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"• 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]
++ String
"\n\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"• 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]
++ String
"\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 a
m = let c :: ManagedPtr a
c = a -> ManagedPtr a
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
                    in (ForeignPtr a -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr (ForeignPtr a -> IO ())
-> (ManagedPtr a -> ForeignPtr a) -> ManagedPtr a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr a -> ForeignPtr a
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr) ManagedPtr a
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 :: (ManagedPtrNewtype o, TypedObject o) =>
                     o -> GType -> IO Bool
checkInstanceType :: o -> GType -> IO Bool
checkInstanceType o
obj (GType 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
$ \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
/= CInt
0

-- | Cast from one object type to another, checking that the cast is
-- valid. If it is not, we return `Nothing`. Usage:
--
-- > maybeWidget <- castTo Widget label
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') -> o -> IO (Maybe o')
castTo ManagedPtr o' -> o'
constructor o
obj = do
  GType
gtype <- TypedObject o' => IO GType
forall a. TypedObject a => IO GType
glibType @o'
  Bool
isInstance <- o -> GType -> IO Bool
forall o.
(ManagedPtrNewtype o, TypedObject o) =>
o -> GType -> IO Bool
checkInstanceType o
obj GType
gtype
  if Bool
isInstance
    then Maybe o' -> IO (Maybe o')
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe o' -> IO (Maybe o'))
-> (ManagedPtr o -> Maybe o') -> ManagedPtr o -> IO (Maybe o')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o' -> Maybe o'
forall a. a -> Maybe a
Just (o' -> Maybe o')
-> (ManagedPtr o -> o') -> ManagedPtr o -> Maybe o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr o' -> o'
constructor (ManagedPtr o' -> o')
-> (ManagedPtr o -> ManagedPtr o') -> ManagedPtr o -> o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr o -> ManagedPtr o'
coerce (ManagedPtr o -> IO (Maybe o')) -> ManagedPtr o -> IO (Maybe o')
forall a b. (a -> b) -> a -> b
$ o -> ManagedPtr o
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr o
obj
    else Maybe o' -> IO (Maybe o')
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe o'
forall a. Maybe a
Nothing

-- | Cast a typed object to a new type (without any assumption that
-- both types descend from `GObject`), assuming that the cast will
-- succeed. This function will call `error` if the cast is illegal.
unsafeCastTo :: forall o o'. (HasCallStack,
                              ManagedPtrNewtype o, TypedObject o,
                              ManagedPtrNewtype o', TypedObject o') =>
                (ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo :: (ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo ManagedPtr o' -> o'
constructor o
obj = do
    GType
gtype <- TypedObject o' => IO GType
forall a. TypedObject a => IO GType
glibType @o'
    Bool
isInstance <- o -> GType -> IO Bool
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 <- TypedObject o => IO GType
forall a. TypedObject a => IO GType
glibType @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 <- TypedObject o' => IO GType
forall a. TypedObject a => IO GType
glibType @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
$ String
"unsafeCastTo :: invalid conversion from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" requested."
      else o' -> IO o'
forall (m :: * -> *) a. Monad m => a -> m a
return (ManagedPtr o' -> o'
constructor (ManagedPtr o' -> o') -> ManagedPtr o' -> o'
forall a b. (a -> b) -> a -> b
$ ManagedPtr o -> ManagedPtr o'
coerce (ManagedPtr o -> ManagedPtr o') -> ManagedPtr o -> ManagedPtr o'
forall a b. (a -> b) -> a -> b
$ o -> ManagedPtr o
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr o
obj)

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

-- | 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 ManagedPtr a -> a
constructor 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 String
"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 ManagedPtr a -> a
constructor 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 String
"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 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 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 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 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 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 Any -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (Ptr Any -> Ptr b) -> IO (Ptr Any) -> IO (Ptr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (Ptr Any)
forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
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, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a
newBoxed :: (ManagedPtr a -> a) -> Ptr a -> IO a
newBoxed ManagedPtr a -> a
constructor Ptr a
ptr = do
  GType CGType
gtype <- TypedObject a => IO GType
forall a. TypedObject a => IO GType
glibType @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, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed :: (ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr a -> a
constructor Ptr a
ptr = do
  GType CGType
gtype <- TypedObject a => IO GType
forall a. TypedObject a => IO GType
glibType @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, GBoxed a) => a -> IO (Ptr a)
copyBoxed :: a -> IO (Ptr a)
copyBoxed a
b = do
  GType CGType
gtype <- TypedObject a => IO GType
forall a. TypedObject a => IO GType
glibType @a
  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. GBoxed a => Ptr a -> IO (Ptr a)
copyBoxedPtr :: Ptr a -> IO (Ptr a)
copyBoxedPtr Ptr a
ptr = do
  GType CGType
gtype <- TypedObject a => IO GType
forall a. TypedObject a => IO GType
glibType @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, GBoxed a) => a -> IO ()
freeBoxed :: a -> IO ()
freeBoxed a
boxed = do
  GType CGType
gtype <- TypedObject a => IO GType
forall a. TypedObject a => IO GType
glibType @a
  Ptr Any
ptr <- a -> IO (Ptr Any)
forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr a
boxed
  a -> IO ()
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc a
boxed
  CGType -> Ptr Any -> IO ()
forall a. CGType -> Ptr a -> IO ()
g_boxed_free CGType
gtype Ptr Any
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 `GBoxed`.
disownBoxed :: (HasCallStack, GBoxed a) => a -> IO (Ptr a)
disownBoxed :: a -> IO (Ptr a)
disownBoxed = a -> IO (Ptr a)
forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
disownManagedPtr

-- | Wrap a pointer, taking ownership of it.
wrapPtr :: (HasCallStack, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a
wrapPtr :: (ManagedPtr a -> a) -> Ptr a -> IO a
wrapPtr ManagedPtr a -> a
constructor Ptr a
ptr = (a -> IO a) -> IO a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((a -> IO a) -> IO a) -> (a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \a
wrapped -> do
  ManagedPtr a
fPtr <- Ptr a -> IO () -> IO (ManagedPtr a)
forall a. HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a)
newManagedPtr Ptr a
ptr (a -> IO ()
forall a. BoxedPtr a => a -> IO ()
boxedPtrFree a
wrapped)
  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, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a
newPtr :: (ManagedPtr a -> a) -> Ptr a -> IO a
newPtr ManagedPtr a -> a
constructor 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. BoxedPtr a => a -> IO a
boxedPtrCopy (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 :: (HasCallStack, CallocPtr a) => Int -> Ptr a -> IO (Ptr a)
copyBytes :: Int -> Ptr a -> IO (Ptr a)
copyBytes Int
size Ptr a
ptr = do
  Ptr a
ptr' <- IO (Ptr a)
forall a. CallocPtr a => IO (Ptr a)
boxedPtrCalloc
  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 ())

-- | Same as `dbgDeallocPtr`, but for `ManagedPtr`s, and no callstack
-- needs to be provided.
dbgDealloc :: (HasCallStack, ManagedPtrNewtype a) => a -> IO ()
dbgDealloc :: 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 -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
_ -> do
      let mPtr :: ManagedPtr a
mPtr = a -> ManagedPtr a
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr a
m
          ptr :: Ptr a
ptr = (ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr (ForeignPtr a -> Ptr a)
-> (ManagedPtr a -> ForeignPtr a) -> ManagedPtr a -> Ptr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedPtr a -> ForeignPtr a
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 <" 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]
++ String
"> 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]
++ String
"].\n"
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ (case ManagedPtr a -> Maybe CallStack
forall a. ManagedPtr a -> Maybe CallStack
managedPtrAllocCallStack ManagedPtr a
mPtr of
                               Just CallStack
allocCS -> String
"• 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]
++ String
"\n\n"
                               Maybe CallStack
Nothing -> String
"")
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"• 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]
++ String
"\n")