module Data.ByteString.Pack
( Packer
, Result(..)
, pack
, putStorable
, putByteString
, fillList
, fillUpWith
, skip
, skipStorable
) where
import Data.ByteString.Internal (ByteString(..))
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Control.Applicative
import Data.Word
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe (unsafePerformIO)
data Cache = Cache !(Ptr Word8)
!Int
instance Show Cache where
show (Cache _ l) = show l
data Result a =
PackerMore a Cache
| PackerFail String
deriving (Show)
newtype Packer a = Packer { runPacker_ :: Cache -> IO (Result a) }
instance Functor Packer where
fmap = fmapPacker
instance Applicative Packer where
pure = returnPacker
(<*>) = appendPacker
instance Monad Packer where
return = returnPacker
(>>=) = bindPacker
fmapPacker :: (a -> b) -> Packer a -> Packer b
fmapPacker f p = Packer $ \cache -> do
rv <- runPacker_ p cache
return $ case rv of
PackerMore v cache' -> PackerMore (f v) cache'
PackerFail err -> PackerFail err
returnPacker :: a -> Packer a
returnPacker v = Packer $ \cache -> return $ PackerMore v cache
bindPacker :: Packer a -> (a -> Packer b) -> Packer b
bindPacker p fp = Packer $ \cache -> do
rv <- runPacker_ p cache
case rv of
PackerMore v cache' -> runPacker_ (fp v) cache'
PackerFail err -> return $ PackerFail err
appendPacker :: Packer (a -> b) -> Packer a -> Packer b
appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v)
pack :: Packer a -> Int -> Either String ByteString
pack p len =
unsafePerformIO $ do
fptr <- B.mallocByteString len
val <- withForeignPtr fptr $ \ptr ->
runPacker_ p (Cache ptr len)
return $ case val of
PackerMore _ (Cache _ r) -> Right (PS fptr 0 (len r))
PackerFail err -> Left err
actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a
actionPacker s action = Packer $ \(Cache ptr size) ->
case compare size s of
LT -> return $ PackerFail "Not enough space in destination"
_ -> do
v <- action ptr
return $ PackerMore v (Cache (ptr `plusPtr` s) (size s))
putStorable :: Storable storable => storable -> Packer ()
putStorable s = actionPacker (sizeOf s) (\ptr -> poke (castPtr ptr) s)
putByteString :: ByteString -> Packer ()
putByteString bs
| neededLength == 0 = return ()
| otherwise = actionPacker neededLength (actionPackerByteString bs)
where
neededLength :: Int
neededLength = B.length bs
actionPackerByteString :: ByteString -> Ptr Word8 -> IO ()
actionPackerByteString (PS fptr off _) ptr =
withForeignPtr fptr $ \srcptr ->
B.memcpy ptr (srcptr `plusPtr` off) neededLength
skip :: Int -> Packer ()
skip n = actionPacker n (\_ -> return ())
skipStorable :: Storable storable => storable -> Packer ()
skipStorable = skip . sizeOf
fillUpWith :: Storable storable => storable -> Packer ()
fillUpWith s = fillList $ repeat s
fillList :: Storable storable => [storable] -> Packer ()
fillList [] = return ()
fillList (x:xs) = putStorable x >> fillList xs