module Codec.ByteString.Builder (
Builder
, toLazyByteString
, empty
, singleton
, putWord8
, putInt8
, append
, fromByteString
, fromLazyByteString
, putString
, flush
, putWord16be
, putWord24be
, putWord32be
, putWord64be
, putInt16be
, putInt32be
, putInt64be
, putWord16le
, putWord24le
, putWord32le
, putWord64le
, putInt16le
, putInt32le
, putInt64le
, putWordHost
, putWord16host
, putWord32host
, putWord64host
, putVarLenBe
, putVarLenLe
) where
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Foreign.Storable (Storable, poke, sizeOf)
import Foreign.Ptr (Ptr, plusPtr)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import System.IO.Unsafe (unsafePerformIO)
import Data.ByteString.Internal (inlinePerformIO,c2w)
import Data.Bits
import Data.Word
import Data.Int
import Data.Monoid
newtype Builder = Builder {
runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
}
instance Monoid Builder where
mempty = empty
mappend = append
empty :: Builder
empty = Builder id
singleton :: Word8 -> Builder
singleton = writeN 1 . flip poke
putWord8 :: Word8 -> Builder
putWord8 = singleton
append :: Builder -> Builder -> Builder
append (Builder f) (Builder g) = Builder (f . g)
fromByteString :: S.ByteString -> Builder
fromByteString bs
| S.null bs = empty
| otherwise = flush `append` mapBuilder (bs :)
fromLazyByteString :: L.ByteString -> Builder
fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++)
putString :: String -> Builder
putString = fromLazyByteString . L.pack . map c2w
data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
toLazyByteString :: Builder -> L.ByteString
toLazyByteString m = L.fromChunks $ unsafePerformIO $ do
buf <- newBuffer defaultSize
return (runBuilder (m `append` flush) (const []) buf)
flush :: Builder
flush = Builder $ \ k buf@(Buffer p o u l) ->
if u == 0
then k buf
else S.PS p o u : k (Buffer p (o+u) 0 l)
defaultSize :: Int
defaultSize = 32 * k - overhead
where k = 1024
overhead = 2 * sizeOf (undefined :: Int)
unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do
buf' <- f buf
return (k buf')
withSize :: (Int -> Builder) -> Builder
withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
runBuilder (f l) k buf
mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder
mapBuilder f = Builder (f .)
ensureFree :: Int -> Builder
ensureFree n = n `seq` withSize $ \ l ->
if n <= l then empty else
flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
writeNBuffer n f (Buffer fp o u l) = do
withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
return (Buffer fp o (u+n) (l-n))
newBuffer :: Int -> IO Buffer
newBuffer size = do
fp <- S.mallocByteString size
return $! Buffer fp 0 0 size
writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder
writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f)
writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer
writeNBufferBytes n f (Buffer fp o u l) = do
withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
return (Buffer fp o (u+n) (l-n))
putWord16be :: Word16 -> Builder
putWord16be w = writeN 2 $ \p -> do
poke p (fromIntegral (shiftR w 8) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (w) :: Word8)
putWord16le :: Word16 -> Builder
putWord16le w = writeN 2 $ \p -> do
poke p (fromIntegral (w) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8)
putWord24be :: Word32 -> Builder
putWord24be w = writeN 3 $ \p -> do
poke p (fromIntegral (shiftR w 16) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (w) :: Word8)
putWord24le :: Word32 -> Builder
putWord24le w = writeN 3 $ \p -> do
poke p (fromIntegral (w) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8)
putWord32be :: Word32 -> Builder
putWord32be w = writeN 4 $ \p -> do
poke p (fromIntegral (shiftR w 24) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (shiftR w 16) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (shiftR w 8) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (w) :: Word8)
putWord32le :: Word32 -> Builder
putWord32le w = writeN 4 $ \p -> do
poke p (fromIntegral (w) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8)
putWord64be :: Word64 -> Builder
putWord64be w = writeN 8 $ \p -> do
poke p (fromIntegral (shiftR w 56) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (shiftR w 48) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (shiftR w 40) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (shiftR w 32) :: Word8)
poke (p `plusPtr` 4) (fromIntegral (shiftR w 24) :: Word8)
poke (p `plusPtr` 5) (fromIntegral (shiftR w 16) :: Word8)
poke (p `plusPtr` 6) (fromIntegral (shiftR w 8) :: Word8)
poke (p `plusPtr` 7) (fromIntegral (w) :: Word8)
putWord64le :: Word64 -> Builder
putWord64le w = writeN 8 $ \p -> do
poke p (fromIntegral (w) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (shiftR w 8) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (shiftR w 16) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (shiftR w 24) :: Word8)
poke (p `plusPtr` 4) (fromIntegral (shiftR w 32) :: Word8)
poke (p `plusPtr` 5) (fromIntegral (shiftR w 40) :: Word8)
poke (p `plusPtr` 6) (fromIntegral (shiftR w 48) :: Word8)
poke (p `plusPtr` 7) (fromIntegral (shiftR w 56) :: Word8)
putInt8 :: Int8 -> Builder
putInt8 = putWord8 . fromIntegral
putInt16le :: Int16 -> Builder
putInt16le = putWord16le . fromIntegral
putInt16be :: Int16 -> Builder
putInt16be = putWord16be . fromIntegral
putInt32le :: Int32 -> Builder
putInt32le = putWord32le . fromIntegral
putInt32be :: Int32 -> Builder
putInt32be = putWord32be . fromIntegral
putInt64le :: Int64 -> Builder
putInt64le = putWord64le . fromIntegral
putInt64be :: Int64 -> Builder
putInt64be = putWord64be . fromIntegral
putWordHost :: Word -> Builder
putWordHost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w)
putWord16host :: Word16 -> Builder
putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16)
putWord32host :: Word32 -> Builder
putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32)
putWord64host :: Word64 -> Builder
putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w)
putVarLenBe :: Word64 -> Builder
putVarLenBe w = varLenAux2 $ reverse $ varLenAux1 w
putVarLenLe :: Word64 -> Builder
putVarLenLe w = varLenAux2 $ varLenAux1 w
varLenAux1 :: Word64 -> [Word8]
varLenAux1 0 = []
varLenAux1 w = (fromIntegral $ w .&. 0x7F) : (varLenAux1 $ shiftR w 7)
varLenAux2 :: [Word8] -> Builder
varLenAux2 [] = putWord8 0
varLenAux2 [w] = putWord8 w
varLenAux2 (w : ws) = putWord8 (setBit w 7) `append` varLenAux2 ws