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 !(ForeignPtr l)
!Word
type role FinalizedPtr phantom
instance Show (FinalizedPtr l) where
show (FinalizedPtr fp o) = show (FP.unsafeForeignPtrToPtr fp
`indexPtr` fromIntegral o)
nullForeignPtr :: ForeignPtr a
nullForeignPtr = unsafePerformIO $ FP.newForeignPtr_ nullPtr
nullFinalizedPtr :: FinalizedPtr a
nullFinalizedPtr = FinalizedPtr nullForeignPtr 0
withFinalizedPtr :: FinalizedPtr a -> (Ptr a -> IO b) -> IO b
withFinalizedPtr (FinalizedPtr fp o) f =
FP.withForeignPtr fp (f . (`indexPtr` fromIntegral o))
class PtrLike (p :: * -> *) where
castPtr :: p a -> p b
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)
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]))
(-->) 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]))
(-#>) 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
nullPtr = Ptr.nullPtr
indexPtr = Ptr.plusPtr
ptrDistance = Ptr.minusPtr
withPtr p f = f p
mallocBytes = liftIO . Ptr.mallocBytes . fromIntegral
instance PtrLike FinalizedPtr where
nullPtr = nullFinalizedPtr
indexPtr (FinalizedPtr fp o) n
| n >= 0 = FinalizedPtr fp (o+fromIntegral n)
| otherwise = FinalizedPtr fp (ofromIntegral (abs n))
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)
withPtr = withFinalizedPtr
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