module Data.Packer.Internal
( Packing(..)
, Hole
, Unpacking(..)
, Memory(..)
, 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, throwIO)
import Control.Monad.State
import Control.Applicative (Applicative(..), (<$>), (<*>))
data Memory = Memory !(Ptr Word8)
!Int
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_ :: (ForeignPtr Word8, Memory) -> Memory -> IO (a, Memory) }
instance Monad Unpacking where
return = returnUnpacking
(>>=) = bindUnpacking
instance Functor Unpacking where
fmap = fmapUnpacking
instance Applicative Unpacking where
pure = returnUnpacking
(<*>) = apUnpacking
bindUnpacking m1 m2 = Unpacking $ \cst st -> do
(a, st2) <- runUnpacking_ m1 cst st
runUnpacking_ (m2 a) cst st2
fmapUnpacking :: (a -> b) -> Unpacking a -> Unpacking b
fmapUnpacking f m = Unpacking $ \cst st -> runUnpacking_ m cst st >>= \(a, st2) -> return (f a, st2)
returnUnpacking :: a -> Unpacking a
returnUnpacking a = Unpacking $ \_ st -> return (a,st)
apUnpacking :: Unpacking (a -> b) -> Unpacking a -> Unpacking b
apUnpacking fm m = fm >>= \p -> m >>= \r2 -> return (p r2)
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 $ \(fptr, iniBlock) st@(Memory ptr sz) -> do
r <- act fptr ptr
return (r, Memory (ptr `plusPtr` n) (sz n))
unpackCheckActRef :: Int -> (ForeignPtr Word8 -> Ptr Word8 -> IO a) -> Unpacking a
unpackCheckActRef n act = Unpacking $ \(fptr, iniBlock@(Memory iniPtr _)) (Memory ptr sz) -> do
when (sz < n) (throwIO $ OutOfBoundUnpacking (ptr `minusPtr` iniPtr) n)
r <- act fptr ptr
return (r, Memory (ptr `plusPtr` n) (sz n))
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 $ \(fptr, iniBlock@(Memory iniPtr sz)) _ -> do
when (pos < 0 || pos >= sz) (throwIO $ OutOfBoundUnpacking pos 0)
return ((), Memory (iniPtr `plusPtr` pos) (szpos))
unpackGetPosition :: Unpacking Int
unpackGetPosition = Unpacking $
\(_, (Memory iniPtr _)) st@(Memory ptr _) -> return (ptr `minusPtr` iniPtr, st)
unpackGetNbRemaining :: Unpacking Int
unpackGetNbRemaining = Unpacking $
\_ st@(Memory _ sz) -> return (sz,st)
unpackLookahead :: (Ptr Word8 -> Int -> IO a)
-> Unpacking a
unpackLookahead f = Unpacking $
\_ st@(Memory ptr sz) -> f ptr sz >>= \a -> return (a, st)
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)