-- |
-- 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 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
(==) FinalPtr a
f1 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 FinalPtr a
f1 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 Ptr a
p1)     (FinalPtr 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 ForeignPtr a
p1) (FinalForeign 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
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 :: Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a)
toFinalPtr Ptr a
ptr 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 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 { (# State# RealWorld
s2, Weak# ()
_ #) -> (# 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 :: GHCF.ForeignPtr a -> FinalPtr a
toFinalPtrForeign :: ForeignPtr a -> FinalPtr a
toFinalPtrForeign 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 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 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
GHCF.castForeignPtr ForeignPtr a
a)

withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a
withFinalPtrNoTouch :: 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 (ForeignPtr p -> Ptr p
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 :: 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
    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 ForeignPtr p
fptr) Ptr p -> prim a
f = do
    a
r <- Ptr p -> prim a
f (ForeignPtr p -> Ptr p
forall a. ForeignPtr a -> Ptr a
GHCF.unsafeForeignPtrToPtr ForeignPtr p
fptr)
    IO () -> prim ()
forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
unsafePrimFromIO (ForeignPtr p -> IO ()
forall a. ForeignPtr a -> IO ()
GHCF.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 p
ptr) = Ptr p -> prim ()
forall (m :: * -> *) a. PrimMonad m => a -> m ()
primTouch Ptr p
ptr
touchFinalPtr (FinalForeign ForeignPtr p
fptr) = IO () -> prim ()
forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
unsafePrimFromIO (ForeignPtr p -> IO ()
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 :: FinalPtr p -> (Ptr p -> prim a) -> a
withUnsafeFinalPtr FinalPtr p
fptr 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 FinalPtr a
f1 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
$ \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
$ \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_ FinalPtr a
f1 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
$ \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
$ \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_ #-}