-- |
-- 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 qualified GHC.ForeignPtr as GHCF
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 (GHCF.ForeignPtr a)
instance Show (FinalPtr a) where
    show :: FinalPtr a -> String
show FinalPtr a
f = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> *) p a.
PrimMonad prim =>
FinalPtr p -> (Ptr p -> prim a) -> prim a
withFinalPtr FinalPtr a
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show)
instance Eq (FinalPtr a) where
    == :: FinalPtr a -> FinalPtr a -> Bool
(==) FinalPtr a
f1 FinalPtr a
f2 = forall a. (forall s. ST s a) -> a
runST (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 FinalPtr a
f1 FinalPtr a
f2 = forall a. (forall s. ST s a) -> a
runST (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 :: forall a b. FinalPtr a -> FinalPtr b -> Bool
finalPtrSameMemory (FinalPtr Ptr a
p1)     (FinalPtr Ptr b
p2)     = Ptr a
p1 forall a. Eq a => a -> a -> Bool
== forall a b. Ptr a -> Ptr b
castPtr Ptr b
p2
finalPtrSameMemory (FinalForeign ForeignPtr a
p1) (FinalForeign ForeignPtr b
p2) = ForeignPtr a
p1 forall a. Eq a => a -> a -> Bool
== forall a b. ForeignPtr a -> ForeignPtr b
GHCF.castForeignPtr ForeignPtr b
p2
finalPtrSameMemory (FinalForeign ForeignPtr a
_)  (FinalPtr Ptr b
_)      = Bool
False
finalPtrSameMemory (FinalPtr Ptr a
_)      (FinalForeign ForeignPtr b
_)  = Bool
False

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

-- | Create a new FinalPtr from a ForeignPtr
toFinalPtrForeign :: GHCF.ForeignPtr a -> FinalPtr a
toFinalPtrForeign :: forall a. ForeignPtr a -> FinalPtr a
toFinalPtrForeign ForeignPtr a
fptr = 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 :: forall a b. FinalPtr a -> FinalPtr b
castFinalPtr (FinalPtr Ptr a
a)     = forall a. Ptr a -> FinalPtr a
FinalPtr (forall a b. Ptr a -> Ptr b
castPtr Ptr a
a)
castFinalPtr (FinalForeign ForeignPtr a
a) = forall a. ForeignPtr a -> FinalPtr a
FinalForeign (forall a b. ForeignPtr a -> ForeignPtr b
GHCF.castForeignPtr ForeignPtr a
a)

withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a
withFinalPtrNoTouch :: forall p a. FinalPtr p -> (Ptr p -> a) -> a
withFinalPtrNoTouch (FinalPtr Ptr p
ptr) Ptr p -> a
f = Ptr p -> a
f Ptr p
ptr
withFinalPtrNoTouch (FinalForeign ForeignPtr p
fptr) Ptr p -> a
f = Ptr p -> a
f (forall a. ForeignPtr a -> Ptr a
GHCF.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 :: forall (prim :: * -> *) p a.
PrimMonad prim =>
FinalPtr p -> (Ptr p -> prim a) -> prim a
withFinalPtr (FinalPtr Ptr p
ptr) Ptr p -> prim a
f = do
    a
r <- Ptr p -> prim a
f Ptr p
ptr
    forall (m :: * -> *) a. PrimMonad m => a -> m ()
primTouch Ptr p
ptr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
withFinalPtr (FinalForeign ForeignPtr p
fptr) Ptr p -> prim a
f = do
    a
r <- Ptr p -> prim a
f (forall a. ForeignPtr a -> Ptr a
GHCF.unsafeForeignPtrToPtr ForeignPtr p
fptr)
    forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
unsafePrimFromIO (forall a. ForeignPtr a -> IO ()
GHCF.touchForeignPtr ForeignPtr p
fptr)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
{-# INLINE withFinalPtr #-}

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

-- | Unsafe version of 'withFinalPtr'
withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a
withUnsafeFinalPtr :: forall (prim :: * -> *) p a.
PrimMonad prim =>
FinalPtr p -> (Ptr p -> prim a) -> a
withUnsafeFinalPtr FinalPtr p
fptr Ptr p -> prim a
f = forall a. IO a -> a
unsafePerformIO (forall (prim :: * -> *) a. PrimMonad prim => prim a -> IO a
unsafePrimToIO (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 :: forall (prim :: * -> *) a.
PrimMonad prim =>
FinalPtr a -> FinalPtr a -> prim Bool
equal FinalPtr a
f1 FinalPtr a
f2 =
    forall (prim :: * -> *) p a.
PrimMonad prim =>
FinalPtr p -> (Ptr p -> prim a) -> prim a
withFinalPtr FinalPtr a
f1 forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr1 ->
    forall (prim :: * -> *) p a.
PrimMonad prim =>
FinalPtr p -> (Ptr p -> prim a) -> prim a
withFinalPtr FinalPtr a
f2 forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr2 ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Ptr a
ptr1 forall a. Eq a => a -> a -> Bool
== Ptr a
ptr2
{-# INLINE equal #-}

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