    -- |
    -- Module      : Basement.FinalPtr
    -- License     : BSD-style
    -- Maintainer  : Vincent Hanquez <vincent@snarc.org>
    -- Stability   : experimental
    -- Portability : portable
    --
    -- A smaller ForeignPtr reimplementation that work in any prim monad.
    --
    -- Here be dragon.
    --
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE UnboxedTuples #-}
    {-# LANGUAGE CPP #-}
    module Basement.FinalPtr
        ( FinalPtr(..)
        , finalPtrSameMemory
        , castFinalPtr
        , toFinalPtr
        , toFinalPtrForeign
        , touchFinalPtr
        , withFinalPtr
        , withUnsafeFinalPtr
        , withFinalPtrNoTouch
        ) where

    import GHC.Ptr
    import GHC.ForeignPtr
    import GHC.IO
    import Basement.Monad
    import Basement.Compat.Primitive
    import Basement.Compat.Base

    import Control.Monad.ST (runST)

    -- | Create a pointer with an associated finalizer
    data FinalPtr a = FinalPtr (Ptr a)
                    | FinalForeign (ForeignPtr a)
    instance Show (FinalPtr a) where
        show :: FinalPtr a -> String
    show f :: FinalPtr a
    f = (forall s. ST s String) -> String
    forall a. (forall s. ST s a) -> a
    runST ((forall s. ST s String) -> String)
    -> (forall s. ST s String) -> String
    forall a b. (a -> b) -> a -> b
    $ FinalPtr a -> (Ptr a -> ST s String) -> ST s String
    forall (prim :: * -> *) p a.
    PrimMonad prim =>
    FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr FinalPtr a
    f (String -> ST s String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> ST s String)
    -> (Ptr a -> String) -> Ptr a -> ST s String
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Ptr a -> String
    forall a. Show a => a -> String
    show)
    instance Eq (FinalPtr a) where
        == :: FinalPtr a -> FinalPtr a -> Bool
    (==) f1 :: FinalPtr a
    f1 f2 :: FinalPtr a
    f2 = (forall s. ST s Bool) -> Bool
    forall a. (forall s. ST s a) -> a
    runST (FinalPtr a -> FinalPtr a -> ST s Bool
    forall (prim :: * -> *) a.
    PrimMonad prim =>
    FinalPtr a -> FinalPtr a -> prim Bool
    equal FinalPtr a
    f1 FinalPtr a
    f2)
    instance Ord (FinalPtr a) where
        compare :: FinalPtr a -> FinalPtr a -> Ordering
    compare f1 :: FinalPtr a
    f1 f2 :: FinalPtr a
    f2 = (forall s. ST s Ordering) -> Ordering
    forall a. (forall s. ST s a) -> a
    runST (FinalPtr a -> FinalPtr a -> ST s Ordering
    forall (prim :: * -> *) a.
    PrimMonad prim =>
    FinalPtr a -> FinalPtr a -> prim Ordering
    compare_ FinalPtr a
    f1 FinalPtr a
    f2)

    -- | Check if 2 final ptr points on the same memory bits
    --
    -- it stand to reason that provided a final ptr that is still being referenced
    -- and thus have the memory still valid, if 2 final ptrs have the
    -- same address, they should be the same final ptr
    finalPtrSameMemory :: FinalPtr a -> FinalPtr b -> Bool
    finalPtrSameMemory :: FinalPtr a -> FinalPtr b -> Bool
    finalPtrSameMemory (FinalPtr p1 :: Ptr a
    p1)     (FinalPtr p2 :: Ptr b
    p2)     = Ptr a
    p1 Ptr a -> Ptr a -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ptr b -> Ptr a
    forall a b. Ptr a -> Ptr b
    castPtr Ptr b
    p2
    finalPtrSameMemory (FinalForeign p1 :: ForeignPtr a
    p1) (FinalForeign p2 :: ForeignPtr b
    p2) = ForeignPtr a
    p1 ForeignPtr a -> ForeignPtr a -> Bool
    forall a. Eq a => a -> a -> Bool
    == ForeignPtr b -> ForeignPtr a
    forall a b. ForeignPtr a -> ForeignPtr b
    castForeignPtr ForeignPtr b
    p2
    finalPtrSameMemory (FinalForeign _)  (FinalPtr _)      = Bool
    False
    finalPtrSameMemory (FinalPtr _)      (FinalForeign _)  = Bool
    False

    -- | create a new FinalPtr from a Pointer
    toFinalPtr :: PrimMonad prim => Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a)
    toFinalPtr :: Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a)
    toFinalPtr ptr :: Ptr a
    ptr finalizer :: Ptr a -> IO ()
    finalizer = IO (FinalPtr a) -> prim (FinalPtr a)
    forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
    unsafePrimFromIO ((State# (PrimState IO) -> (# State# (PrimState IO), FinalPtr a #))
    -> IO (FinalPtr a)
    forall (m :: * -> *) a.
    PrimMonad m =>
    (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
    primitive State# RealWorld -> (# State# RealWorld, FinalPtr a #)
    State# (PrimState IO) -> (# State# (PrimState IO), FinalPtr a #)
    makeWithFinalizer)
      where
        makeWithFinalizer :: State# RealWorld -> (# State# RealWorld, FinalPtr a #)
    makeWithFinalizer s :: State# RealWorld
    s =
            case Ptr a
    -> ()
    -> IO ()
    -> State# RealWorld
    -> (# State# RealWorld, Weak# () #)
    forall o b.
    o
    -> b
    -> IO ()
    -> State# RealWorld
    -> (# State# RealWorld, Weak# b #)
    compatMkWeak# Ptr a
    ptr () (Ptr a -> IO ()
    finalizer Ptr a
    ptr) State# RealWorld
    s of { (# s2 :: State# RealWorld
    s2, _ #) -> (# State# RealWorld
    s2, Ptr a -> FinalPtr a
    forall a. Ptr a -> FinalPtr a
    FinalPtr Ptr a
    ptr #) }

    -- | Create a new FinalPtr from a ForeignPtr
    toFinalPtrForeign :: ForeignPtr a -> FinalPtr a
    toFinalPtrForeign :: ForeignPtr a -> FinalPtr a
    toFinalPtrForeign fptr :: ForeignPtr a
    fptr = ForeignPtr a -> FinalPtr a
    forall a. ForeignPtr a -> FinalPtr a
    FinalForeign ForeignPtr a
    fptr

    -- | Cast a finalized pointer from type a to type b
    castFinalPtr :: FinalPtr a -> FinalPtr b
    castFinalPtr :: FinalPtr a -> FinalPtr b
    castFinalPtr (FinalPtr a :: Ptr a
    a)     = Ptr b -> FinalPtr b
    forall a. Ptr a -> FinalPtr a
    FinalPtr (Ptr a -> Ptr b
    forall a b. Ptr a -> Ptr b
    castPtr Ptr a
    a)
    castFinalPtr (FinalForeign a :: ForeignPtr a
    a) = ForeignPtr b -> FinalPtr b
    forall a. ForeignPtr a -> FinalPtr a
    FinalForeign (ForeignPtr a -> ForeignPtr b
    forall a b. ForeignPtr a -> ForeignPtr b
    castForeignPtr ForeignPtr a
    a)

    withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a
    withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a
    withFinalPtrNoTouch (FinalPtr ptr :: Ptr p
    ptr) f :: Ptr p -> a
    f = Ptr p -> a
    f Ptr p
    ptr
    withFinalPtrNoTouch (FinalForeign fptr :: ForeignPtr p
    fptr) f :: Ptr p -> a
    f = Ptr p -> a
    f (ForeignPtr p -> Ptr p
    forall a. ForeignPtr a -> Ptr a
    unsafeForeignPtrToPtr ForeignPtr p
    fptr)
    {-# INLINE withFinalPtrNoTouch #-}

    -- | Looks at the raw pointer inside a FinalPtr, making sure the
    -- data pointed by the pointer is not finalized during the call to 'f'
    withFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr :: FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr (FinalPtr ptr :: Ptr p
    ptr) f :: Ptr p -> prim a
    f = do
        a
    r <- Ptr p -> prim a
    f Ptr p
    ptr
        Ptr p -> prim ()
    forall (m :: * -> *) a. PrimMonad m => a -> m ()
    primTouch Ptr p
    ptr
        a -> prim a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    r
    withFinalPtr (FinalForeign fptr :: ForeignPtr p
    fptr) f :: Ptr p -> prim a
    f = do
        a
    r <- Ptr p -> prim a
    f (ForeignPtr p -> Ptr p
    forall a. ForeignPtr a -> Ptr a
    unsafeForeignPtrToPtr ForeignPtr p
    fptr)
        IO () -> prim ()
    forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
    unsafePrimFromIO (ForeignPtr p -> IO ()
    forall a. ForeignPtr a -> IO ()
    touchForeignPtr ForeignPtr p
    fptr)
        a -> prim a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    r
    {-# INLINE withFinalPtr #-}

    touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim ()
    touchFinalPtr :: FinalPtr p -> prim ()
    touchFinalPtr (FinalPtr ptr :: Ptr p
    ptr) = Ptr p -> prim ()
    forall (m :: * -> *) a. PrimMonad m => a -> m ()
    primTouch Ptr p
    ptr
    touchFinalPtr (FinalForeign fptr :: ForeignPtr p
    fptr) = IO () -> prim ()
    forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
    unsafePrimFromIO (ForeignPtr p -> IO ()
    forall a. ForeignPtr a -> IO ()
    touchForeignPtr ForeignPtr p
    fptr)

    -- | Unsafe version of 'withFinalPtr'
    withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a
    withUnsafeFinalPtr :: FinalPtr p -> (Ptr p -> prim a) -> a
    withUnsafeFinalPtr fptr :: FinalPtr p
    fptr f :: Ptr p -> prim a
    f = IO a -> a
    forall a. IO a -> a
    unsafePerformIO (prim a -> IO a
    forall (prim :: * -> *) a. PrimMonad prim => prim a -> IO a
    unsafePrimToIO (FinalPtr p -> (Ptr p -> prim a) -> prim a
    forall (prim :: * -> *) p a.
    PrimMonad prim =>
    FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr FinalPtr p
    fptr Ptr p -> prim a
    f))
    {-# NOINLINE withUnsafeFinalPtr #-}

    equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool
    equal :: FinalPtr a -> FinalPtr a -> prim Bool
    equal f1 :: FinalPtr a
    f1 f2 :: FinalPtr a
    f2 =
        FinalPtr a -> (Ptr a -> prim Bool) -> prim Bool
    forall (prim :: * -> *) p a.
    PrimMonad prim =>
    FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr FinalPtr a
    f1 ((Ptr a -> prim Bool) -> prim Bool)
    -> (Ptr a -> prim Bool) -> prim Bool
    forall a b. (a -> b) -> a -> b
    $ \ptr1 :: Ptr a
    ptr1 ->
        FinalPtr a -> (Ptr a -> prim Bool) -> prim Bool
    forall (prim :: * -> *) p a.
    PrimMonad prim =>
    FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr FinalPtr a
    f2 ((Ptr a -> prim Bool) -> prim Bool)
    -> (Ptr a -> prim Bool) -> prim Bool
    forall a b. (a -> b) -> a -> b
    $ \ptr2 :: Ptr a
    ptr2 ->
            Bool -> prim Bool
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Bool -> prim Bool) -> Bool -> prim Bool
    forall a b. (a -> b) -> a -> b
    $ Ptr a
    ptr1 Ptr a -> Ptr a -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ptr a
    ptr2
    {-# INLINE equal #-}

    compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering
    compare_ :: FinalPtr a -> FinalPtr a -> prim Ordering
    compare_ f1 :: FinalPtr a
    f1 f2 :: FinalPtr a
    f2 =
        FinalPtr a -> (Ptr a -> prim Ordering) -> prim Ordering
    forall (prim :: * -> *) p a.
    PrimMonad prim =>
    FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr FinalPtr a
    f1 ((Ptr a -> prim Ordering) -> prim Ordering)
    -> (Ptr a -> prim Ordering) -> prim Ordering
    forall a b. (a -> b) -> a -> b
    $ \ptr1 :: Ptr a
    ptr1 ->
        FinalPtr a -> (Ptr a -> prim Ordering) -> prim Ordering
    forall (prim :: * -> *) p a.
    PrimMonad prim =>
    FinalPtr p -> (Ptr p -> prim a) -> prim a
    withFinalPtr FinalPtr a
    f2 ((Ptr a -> prim Ordering) -> prim Ordering)
    -> (Ptr a -> prim Ordering) -> prim Ordering
    forall a b. (a -> b) -> a -> b
    $ \ptr2 :: Ptr a
    ptr2 ->
            Ordering -> prim Ordering
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Ordering -> prim Ordering) -> Ordering -> prim Ordering
    forall a b. (a -> b) -> a -> b
    $ Ptr a
    ptr1 Ptr a -> Ptr a -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` Ptr a
    ptr2
    {-# INLINE compare_ #-}