module Data.Packer.Internal
( Packing(..)
, Hole
, Unpacking(..)
, Memory(..)
, UnpackSt(..)
, PackSt(..)
, OutOfBoundUnpacking(..)
, OutOfBoundPacking(..)
, HoleInPacking(..)
, unpackUnsafeActRef
, unpackCheckActRef
, unpackUnsafeAct
, unpackCheckAct
, unpackLookahead
, unpackSetPosition
, unpackGetPosition
, unpackGetNbRemaining
, packCheckAct
, packHole
, packGetPosition
, fillHole
) where
import Foreign.Ptr
import Foreign.ForeignPtr
import Data.Data
import Data.Word
import Control.Exception (Exception, throw)
import Control.Monad.State
import Control.Applicative (Applicative, (<$>), (<*>))
data Memory = Memory !(Ptr Word8)
!Int
data UnpackSt = UnpackSt !(ForeignPtr Word8) !Memory !Memory
data PackSt = PackSt (Ptr Word8) !Int !Memory
newtype Packing a = Packing { runPacking_ :: StateT PackSt IO a }
deriving (Functor,Applicative,Monad,MonadIO)
newtype Unpacking a = Unpacking { runUnpacking_ :: StateT UnpackSt IO a }
deriving (Functor,Applicative,Monad,MonadIO)
data OutOfBoundPacking = OutOfBoundPacking Int
Int
deriving (Show,Eq,Data,Typeable)
data HoleInPacking = HoleInPacking Int
deriving (Show,Eq,Data,Typeable)
data OutOfBoundUnpacking = OutOfBoundUnpacking Int
Int
deriving (Show,Eq,Data,Typeable)
instance Exception OutOfBoundPacking
instance Exception HoleInPacking
instance Exception OutOfBoundUnpacking
unpackUnsafeActRef :: Int -> (ForeignPtr Word8 -> Ptr Word8 -> IO a) -> Unpacking a
unpackUnsafeActRef n act = Unpacking $ do
(UnpackSt fptr iniBlock (Memory ptr sz)) <- get
r <- lift (act fptr ptr)
put (UnpackSt fptr iniBlock (Memory (ptr `plusPtr` n) (sz n)))
return r
unpackCheckActRef :: Int -> (ForeignPtr Word8 -> Ptr Word8 -> IO a) -> Unpacking a
unpackCheckActRef n act = Unpacking $ do
(UnpackSt fptr iniBlock@(Memory iniPtr _) (Memory ptr sz)) <- get
when (sz < n) (lift $ throw $ OutOfBoundUnpacking (ptr `minusPtr` iniPtr) n)
r <- lift (act fptr ptr)
put (UnpackSt fptr iniBlock (Memory (ptr `plusPtr` n) (sz n)))
return r
unpackUnsafeAct :: Int -> (Ptr Word8 -> IO a) -> Unpacking a
unpackUnsafeAct n act = unpackUnsafeActRef n (\_ -> act)
unpackCheckAct :: Int -> (Ptr Word8 -> IO a) -> Unpacking a
unpackCheckAct n act = unpackCheckActRef n (\_ -> act)
unpackSetPosition :: Int -> Unpacking ()
unpackSetPosition pos = Unpacking $ do
(UnpackSt fptr iniBlock@(Memory iniPtr sz) _) <- get
when (pos < 0 || pos >= sz) (lift $ throw $ OutOfBoundUnpacking pos 0)
put (UnpackSt fptr iniBlock (Memory (iniPtr `plusPtr` pos) (szpos)))
unpackGetPosition :: Unpacking Int
unpackGetPosition = Unpacking $ gets (\(UnpackSt _ (Memory iniPtr _) (Memory ptr _)) -> ptr `minusPtr` iniPtr)
unpackGetNbRemaining :: Unpacking Int
unpackGetNbRemaining = Unpacking $ gets (\(UnpackSt _ _ (Memory _ sz)) -> sz)
unpackLookahead :: (Ptr Word8 -> Int -> IO a)
-> Unpacking a
unpackLookahead f = Unpacking $ do
(UnpackSt _ _ (Memory ptr sz)) <- get
lift $ f ptr sz
withPackMemory :: Int -> (Ptr Word8 -> IO a) -> StateT PackSt IO a
withPackMemory n act = do
(PackSt iPos holes (Memory ptr sz)) <- get
when (sz < n) (lift $ throw $ OutOfBoundPacking sz n)
r <- lift (act ptr)
put $ PackSt iPos holes (Memory (ptr `plusPtr` n) (sz n))
return r
modifyHoles :: (Int -> Int) -> Packing ()
modifyHoles f = Packing $ modify (\(PackSt iPos holes mem) -> PackSt iPos (f holes) mem)
packCheckAct :: Int -> (Ptr Word8 -> IO a) -> Packing a
packCheckAct n act = Packing (withPackMemory n act)
packGetPosition :: Packing Int
packGetPosition = Packing $ gets (\(PackSt iniPtr _ (Memory ptr _)) -> ptr `minusPtr` iniPtr)
newtype Hole a = Hole (a -> IO ())
packHole :: Int -> (Ptr Word8 -> a -> IO ()) -> Packing (Hole a)
packHole n f = do
r <- packCheckAct n (\ptr -> return $ Hole (\w -> f ptr w))
modifyHoles (1 +)
return r
fillHole :: Hole a -> a -> Packing ()
fillHole (Hole closure) a = modifyHoles (\i -> i 1) >> Packing (lift $ closure a)