{-# 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 Unsafe.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
{-# INLINE withFinalizedPtr #-}
withFinalizedPtr (FinalizedPtr fp o) f =
FP.withForeignPtr fp (f . (`indexPtr` fromIntegral o))
class PtrLike (p :: * -> *) where
castPtr :: p a -> p b
{-# INLINE castPtr #-}
castPtr = unsafeCoerce
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)
indexField :: forall path l.
( KnownNat (LayoutPathOffset l path)
) => p l -> path -> p (LayoutPathType l path)
{-# INLINE indexField #-}
indexField p _ = castPtr (p `indexPtr` natValue @(LayoutPathOffset l path))
(-->) :: forall s l.
( KnownNat (LayoutPathOffset l (LayoutPath '[LayoutSymbol s]))
) => p l -> LayoutSymbol s -> p (LayoutPathType l (LayoutPath '[LayoutSymbol s]))
{-# INLINE (-->) #-}
(-->) l _ = indexField l (layoutSymbol :: LayoutPath '[LayoutSymbol s])
(-#>) :: forall n l.
( KnownNat (LayoutPathOffset l (LayoutPath '[LayoutIndex n]))
) => p l -> LayoutIndex n -> p (LayoutPathType l (LayoutPath '[LayoutIndex n]))
{-# INLINE (-#>) #-}
(-#>) l _ = indexField l (layoutIndex :: LayoutPath '[LayoutIndex n])
indexPtr' :: Integral b => Ptr a -> b -> Ptr a
indexPtr' p a = indexPtr p (fromIntegral a)
instance PtrLike Ptr where
{-# INLINE nullPtr #-}
nullPtr = Ptr.nullPtr
{-# INLINE indexPtr #-}
indexPtr = Ptr.plusPtr
{-# INLINE ptrDistance #-}
ptrDistance = Ptr.minusPtr
{-# INLINE withPtr #-}
withPtr p f = f p
{-# INLINE mallocBytes #-}
mallocBytes = liftIO . Ptr.mallocBytes . fromIntegral
instance PtrLike FinalizedPtr where
{-# INLINE nullPtr #-}
nullPtr = nullFinalizedPtr
{-# INLINE indexPtr #-}
indexPtr (FinalizedPtr fp o) n
| n >= 0 = FinalizedPtr fp (o+fromIntegral n)
| otherwise = FinalizedPtr fp (o-fromIntegral (abs n))
{-# INLINE 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)
{-# INLINE withPtr #-}
withPtr = withFinalizedPtr
{-# INLINE 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