-- |
-- Module      : Basement.FinalPtr
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <[email protected]>
-- 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 f = runST $ withFinalPtr f (pure . show)
instance Eq (FinalPtr a) where
    (==) f1 f2 = runST (equal f1 f2)
instance Ord (FinalPtr a) where
    compare f1 f2 = runST (compare_ f1 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 p1)     (FinalPtr p2)     = p1 == castPtr p2
finalPtrSameMemory (FinalForeign p1) (FinalForeign p2) = p1 == castForeignPtr p2
finalPtrSameMemory (FinalForeign _)  (FinalPtr _)      = False
finalPtrSameMemory (FinalPtr _)      (FinalForeign _)  = False

-- | create a new FinalPtr from a Pointer
toFinalPtr :: PrimMonad prim => Ptr a -> (Ptr a -> IO ()) -> prim (FinalPtr a)
toFinalPtr ptr finalizer = unsafePrimFromIO (primitive makeWithFinalizer)
  where
    makeWithFinalizer s =
        case compatMkWeak# ptr () (finalizer ptr) s of { (# s2, _ #) -> (# s2, FinalPtr ptr #) }

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

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

withFinalPtrNoTouch :: FinalPtr p -> (Ptr p -> a) -> a
withFinalPtrNoTouch (FinalPtr ptr) f = f ptr
withFinalPtrNoTouch (FinalForeign fptr) f = f (unsafeForeignPtrToPtr 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 ptr) f = do
    r <- f ptr
    primTouch ptr
    pure r
withFinalPtr (FinalForeign fptr) f = do
    r <- f (unsafeForeignPtrToPtr fptr)
    unsafePrimFromIO (touchForeignPtr fptr)
    pure r
{-# INLINE withFinalPtr #-}

touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim ()
touchFinalPtr (FinalPtr ptr) = primTouch ptr
touchFinalPtr (FinalForeign fptr) = unsafePrimFromIO (touchForeignPtr fptr)

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

equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool
equal f1 f2 =
    withFinalPtr f1 $ \ptr1 ->
    withFinalPtr f2 $ \ptr2 ->
        pure $ ptr1 == ptr2
{-# INLINE equal #-}

compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering
compare_ f1 f2 =
    withFinalPtr f1 $ \ptr1 ->
    withFinalPtr f2 $ \ptr2 ->
        pure $ ptr1 `compare` ptr2
{-# INLINE compare_ #-}