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