{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
module Haskus.Format.Binary.Ptr
( PtrLike (..)
, indexPtr'
, Ptr (..)
, free
, FinalizedPtr (..)
, withFinalizedPtr
, ForeignPtr
, withForeignPtr
, mallocForeignPtrBytes
, nullForeignPtr
, Ptr.FunPtr
, Ptr.nullFunPtr
, Ptr.castPtrToFunPtr
, Ptr.castFunPtrToPtr
, Ptr.WordPtr
, Ptr.wordPtrToPtr
, Ptr.ptrToWordPtr
)
where
import qualified Foreign.Ptr as Ptr
import qualified Foreign.Marshal.Alloc as Ptr
import qualified Foreign.ForeignPtr as FP
import qualified Foreign.ForeignPtr.Unsafe as FP
import GHC.Ptr (Ptr (..))
import Foreign.ForeignPtr (ForeignPtr)
import Data.Coerce
import System.IO.Unsafe
import Haskus.Format.Binary.Layout
import Haskus.Utils.Types
import Haskus.Utils.Monad
data FinalizedPtr l = FinalizedPtr {-# UNPACK #-} !(ForeignPtr l)
{-# UNPACK #-} !Word
type role FinalizedPtr phantom
instance Show (FinalizedPtr l) where
show (FinalizedPtr fp o) = show (FP.unsafeForeignPtrToPtr fp
`indexPtr` fromIntegral o)
nullForeignPtr :: ForeignPtr a
{-# NOINLINE nullForeignPtr #-}
nullForeignPtr = unsafePerformIO $ FP.newForeignPtr_ nullPtr
nullFinalizedPtr :: FinalizedPtr a
nullFinalizedPtr = FinalizedPtr nullForeignPtr 0
withFinalizedPtr :: FinalizedPtr a -> (Ptr a -> IO b) -> IO b
{-# INLINABLE withFinalizedPtr #-}
withFinalizedPtr (FinalizedPtr fp o) f =
FP.withForeignPtr fp (f . (`indexPtr` fromIntegral o))
class PtrLike (p :: * -> *) where
castPtr :: p a -> p b
nullPtr :: forall a. p a
indexPtr :: p a -> Int -> p a
ptrDistance :: p a -> p b -> Int
withPtr :: p a -> (Ptr a -> IO b) -> IO b
mallocBytes :: MonadIO m => Word -> m (p a)
(-->) :: forall path l.
( KnownNat (LPathOffset path l)
) => p l -> path -> p (LPathType path l)
{-# INLINABLE (-->) #-}
(-->) p _ = castPtr (p `indexPtr` natValue @(LPathOffset path l))
indexPtr' :: Integral b => Ptr a -> b -> Ptr a
indexPtr' p a = indexPtr p (fromIntegral a)
instance PtrLike Ptr where
{-# INLINABLE castPtr #-}
castPtr = coerce
{-# INLINABLE nullPtr #-}
nullPtr = Ptr.nullPtr
{-# INLINABLE indexPtr #-}
indexPtr = Ptr.plusPtr
{-# INLINABLE ptrDistance #-}
ptrDistance = Ptr.minusPtr
{-# INLINABLE withPtr #-}
withPtr p f = f p
{-# INLINABLE mallocBytes #-}
mallocBytes = liftIO . Ptr.mallocBytes . fromIntegral
instance PtrLike FinalizedPtr where
{-# INLINABLE castPtr #-}
castPtr = coerce
{-# INLINABLE nullPtr #-}
nullPtr = nullFinalizedPtr
{-# INLINABLE indexPtr #-}
indexPtr (FinalizedPtr fp o) n
| n >= 0 = FinalizedPtr fp (o+fromIntegral n)
| otherwise = FinalizedPtr fp (o-fromIntegral (abs n))
{-# INLINABLE ptrDistance #-}
ptrDistance (FinalizedPtr fp1 o1) (FinalizedPtr fp2 o2)
| o2 > o1 = d + fromIntegral (o2 - o1)
| otherwise = d - fromIntegral (o1 - o2)
where
d = ptrDistance (FP.unsafeForeignPtrToPtr fp1)
(FP.unsafeForeignPtrToPtr fp2)
{-# INLINABLE withPtr #-}
withPtr = withFinalizedPtr
{-# INLINABLE mallocBytes #-}
mallocBytes n = do
fp <- mallocForeignPtrBytes (fromIntegral n)
return (FinalizedPtr fp 0)
mallocForeignPtrBytes :: MonadIO m => Word -> m (ForeignPtr a)
mallocForeignPtrBytes = liftIO . FP.mallocForeignPtrBytes . fromIntegral
withForeignPtr :: (MonadInIO m) => ForeignPtr a -> (Ptr a -> m b) -> m b
withForeignPtr p = liftWith (FP.withForeignPtr p)
free :: MonadIO m => Ptr a -> m ()
free = liftIO . Ptr.free