diff --git a/Data/ByteString.hs b/Data/ByteString.hs --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -56,6 +56,7 @@ append, -- :: ByteString -> ByteString -> ByteString head, -- :: ByteString -> Word8 uncons, -- :: ByteString -> Maybe (Word8, ByteString) + unsnoc, -- :: ByteString -> Maybe (ByteString, Word8) last, -- :: ByteString -> Word8 tail, -- :: ByteString -> ByteString init, -- :: ByteString -> ByteString @@ -270,7 +271,7 @@ import GHC.IO.Handle.Types import GHC.IO.Buffer import GHC.IO.BufferedIO as Buffered -import GHC.IO (unsafePerformIO, unsafeDupablePerformIO) +import GHC.IO (unsafePerformIO) import Data.Char (ord) import Foreign.Marshal.Utils (copyBytes) #else @@ -300,10 +301,6 @@ hWaitForInput _ _ = return () #endif -#ifndef __GLASGOW_HASKELL__ -unsafeDupablePerformIO = unsafePerformIO -#endif - -- ----------------------------------------------------------------------------- -- -- Useful macros, until we have bang patterns @@ -467,6 +464,16 @@ | otherwise = PS p s (l-1) {-# INLINE init #-} +-- | /O(1)/ Extract the 'init' and 'last' of a ByteString, returning Nothing +-- if it is empty. +unsnoc :: ByteString -> Maybe (ByteString, Word8) +unsnoc (PS x s l) + | l <= 0 = Nothing + | otherwise = Just (PS x s (l-1), + inlinePerformIO $ withForeignPtr x + $ \p -> peekByteOff p (s+l-1)) +{-# INLINE unsnoc #-} + -- | /O(n)/ Append two ByteStrings append :: ByteString -> ByteString -> ByteString append = mappend @@ -476,9 +483,9 @@ -- Transformations -- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each --- element of @xs@. +-- element of @xs@. This function is subject to array fusion. map :: (Word8 -> Word8) -> ByteString -> ByteString -map f (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> +map f (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a -> create len $ map_ 0 (a `plusPtr` s) where map_ :: Int -> Ptr Word8 -> Ptr Word8 -> IO () @@ -518,6 +525,8 @@ -- the left-identity of the operator), and a ByteString, reduces the -- ByteString using the binary operator, from left to right. -- +-- This function is subject to array fusion. +-- foldl :: (a -> Word8 -> a) -> a -> ByteString -> a foldl f v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> lgo v (ptr `plusPtr` s) (ptr `plusPtr` (s+l)) @@ -561,6 +570,7 @@ -- | 'foldl1' is a variant of 'foldl' that has no starting value -- argument, and thus must be applied to non-empty 'ByteStrings'. +-- This function is subject to array fusion. -- An exception will be thrown in the case of an empty ByteString. foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldl1 f ps @@ -582,7 +592,7 @@ foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldr1 f ps | null ps = errorEmptyList "foldr1" - | otherwise = foldr f (last ps) (init ps) + | otherwise = foldr f (unsafeLast ps) (unsafeInit ps) {-# INLINE foldr1 #-} -- | 'foldr1\'' is a variant of 'foldr1', but is strict in the @@ -590,7 +600,7 @@ foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldr1' f ps | null ps = errorEmptyList "foldr1" - | otherwise = foldr' f (last ps) (init ps) + | otherwise = foldr' f (unsafeLast ps) (unsafeInit ps) {-# INLINE foldr1' #-} -- --------------------------------------------------------------------- @@ -666,7 +676,7 @@ -- passing an accumulating parameter from left to right, and returning a -- final value of this accumulator together with the new list. mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) -mapAccumL f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do +mapAccumL f acc (PS fp o len) = inlinePerformIO $ withForeignPtr fp $ \a -> do gp <- mallocByteString len acc' <- withForeignPtr gp $ \p -> mapAccumL_ acc 0 (a `plusPtr` o) p return $! (acc', PS gp 0 len) @@ -686,7 +696,7 @@ -- passing an accumulating parameter from right to left, and returning a -- final value of this accumulator together with the new ByteString. mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) -mapAccumR f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do +mapAccumR f acc (PS fp o len) = inlinePerformIO $ withForeignPtr fp $ \a -> do gp <- mallocByteString len acc' <- withForeignPtr gp $ \p -> mapAccumR_ acc (len-1) (a `plusPtr` o) p return $! (acc', PS gp 0 len) @@ -715,7 +725,7 @@ -- scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString -scanl f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> +scanl f v (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a -> create (len+1) $ \q -> do poke q v scanl_ v 0 (a `plusPtr` s) (q `plusPtr` 1) @@ -746,7 +756,7 @@ -- | scanr is the right-to-left dual of scanl. scanr :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString -scanr f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> +scanr f v (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a -> create (len+1) $ \q -> do poke (q `plusPtr` len) v scanr_ v (len-1) (a `plusPtr` s) q @@ -765,7 +775,7 @@ scanr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString scanr1 f ps | null ps = empty - | otherwise = scanr f (last ps) (init ps) -- todo, unsafe versions + | otherwise = scanr f (unsafeLast ps) (unsafeInit ps) {-# INLINE scanr1 #-} -- --------------------------------------------------------------------- @@ -1257,7 +1267,7 @@ -- | /O(n)/ 'filter', applied to a predicate and a ByteString, -- returns a ByteString containing those characters that satisfy the --- predicate. +-- predicate. This function is subject to array fusion. filter :: (Word8 -> Bool) -> ByteString -> ByteString filter k ps@(PS x s l) | null ps = ps @@ -1499,7 +1509,7 @@ -- performed on the result of zipWith. -- zipWith' :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString -zipWith' f (PS fp s l) (PS fq t m) = unsafeDupablePerformIO $ +zipWith' f (PS fp s l) (PS fq t m) = inlinePerformIO $ withForeignPtr fp $ \a -> withForeignPtr fq $ \b -> create len $ zipWith_ 0 (a `plusPtr` s) (b `plusPtr` t) @@ -2022,5 +2032,5 @@ STRICT2(findFromEndUntil) findFromEndUntil f ps@(PS x s l) = if null ps then 0 - else if f (last ps) then l + else if f (unsafeLast ps) then l else findFromEndUntil f (PS x s (l-1)) diff --git a/Data/ByteString/Builder.hs b/Data/ByteString/Builder.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{- | Copyright : (c) 2010 Jasper Van der Jeugt + (c) 2010 - 2011 Simon Meier +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +'Builder's are used to efficiently construct sequences of bytes from + smaller parts. +Typically, + such a construction is part of the implementation of an /encoding/, i.e., + a function for converting Haskell values to sequences of bytes. +Examples of encodings are the generation of the sequence of bytes + representing a HTML document to be sent in a HTTP response by a + web application or the serialization of a Haskell value using + a fixed binary format. + +For an /efficient implementation of an encoding/, + it is important that (a) little time is spent on converting + the Haskell values to the resulting sequence of bytes /and/ + (b) that the representation of the resulting sequence + is such that it can be consumed efficiently. +'Builder's support (a) by providing an /O(1)/ concatentation operation + and efficient implementations of basic encodings for 'Char's, 'Int's, + and other standard Haskell values. +They support (b) by providing their result as a lazy 'L.ByteString', + which is internally just a linked list of pointers to /chunks/ + of consecutive raw memory. +Lazy 'L.ByteString's can be efficiently consumed by functions that + write them to a file or send them over a network socket. +Note that each chunk boundary incurs expensive extra work (e.g., a system call) + that must be amortized over the work spent on consuming the chunk body. +'Builder's therefore take special care to ensure that the + average chunk size is large enough. +The precise meaning of large enough is application dependent. +The current implementation is tuned + for an average chunk size between 4kb and 32kb, + which should suit most applications. + +As a simple example of an encoding implementation, + we show how to efficiently convert the following representation of mixed-data + tables to an UTF-8 encoded Comma-Separated-Values (CSV) table. + +>data Cell = StringC String +> | IntC Int +> deriving( Eq, Ord, Show ) +> +>type Row = [Cell] +>type Table = [Row] + +We use the following imports and abbreviate 'mappend' to simplify reading. + +@ +import qualified "Data.ByteString.Lazy" as L +import "Data.ByteString.Builder" +import "Data.ByteString.Builder.ASCII" ('intDec') +import Data.Monoid +import Data.Foldable ('foldMap') +import Data.List ('intersperse') + +infixr 4 \<\> +(\<\>) :: 'Monoid' m => m -> m -> m +(\<\>) = 'mappend' +@ + +CSV is a character-based representation of tables. For maximal modularity, +we could first render 'Table's as 'String's and then encode this 'String' +using some Unicode character encoding. However, this sacrifices performance +due to the intermediate 'String' representation being built and thrown away +right afterwards. We get rid of this intermediate 'String' representation by +fixing the character encoding to UTF-8 and using 'Builder's to convert +'Table's directly to UTF-8 encoded CSV tables represented as lazy +'L.ByteString's. + +@ +encodeUtf8CSV :: Table -> L.ByteString +encodeUtf8CSV = 'toLazyByteString' . renderTable + +renderTable :: Table -> Builder +renderTable rs = 'mconcat' [renderRow r \<\> 'charUtf8' \'\\n\' | r <- rs] + +renderRow :: Row -> Builder +renderRow [] = 'mempty' +renderRow (c:cs) = + renderCell c \<\> mconcat [ charUtf8 \',\' \<\> renderCell c\' | c\' <- cs ] + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = 'intDec' i + +renderString :: String -> Builder +renderString cs = charUtf8 \'\"\' \<\> foldMap escape cs \<\> charUtf8 \'\"\' + where + escape \'\\\\\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\\\' + escape \'\\\"\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\"\' + escape c = charUtf8 c +@ + +Note that the ASCII encoding is a subset of the UTF-8 encoding, + which is why we can use the optimized function 'intDec' to + encode an 'Int' as a decimal number with UTF-8 encoded digits. +Using 'intDec' is more efficient than @'stringUtf8' . 'show'@, + as it avoids constructing an intermediate 'String'. +Avoiding this intermediate data structure significantly improves + performance because encoding 'Cell's is the core operation + for rendering CSV-tables. +See "Data.ByteString.Builder.Prim" for further + information on how to improve the performance of 'renderString'. + +We demonstrate our UTF-8 CSV encoding function on the following table. + +@ +strings :: [String] +strings = [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] + +table :: Table +table = [map StringC strings, map IntC [-3..3]] +@ + +The expression @encodeUtf8CSV table@ results in the following lazy +'L.ByteString'. + +>Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty + +We can clearly see that we are converting to a /binary/ format. The \'λ\' +and \'ö\' characters, which have a Unicode codepoint above 127, are +expanded to their corresponding UTF-8 multi-byte representation. + +We use the @criterion@ library () + to benchmark the efficiency of our encoding function on the following table. + +>import Criterion.Main -- add this import to the ones above +> +>maxiTable :: Table +>maxiTable = take 1000 $ cycle table +> +>main :: IO () +>main = defaultMain +> [ bench "encodeUtf8CSV maxiTable (original)" $ +> whnf (L.length . encodeUtf8CSV) maxiTable +> ] + +On a Core2 Duo 2.20GHz on a 32-bit Linux, + the above code takes 1ms to generate the 22'500 bytes long lazy 'L.ByteString'. +Looking again at the definitions above, + we see that we took care to avoid intermediate data structures, + as otherwise we would sacrifice performance. +For example, + the following (arguably simpler) definition of 'renderRow' is about 20% slower. + +>renderRow :: Row -> Builder +>renderRow = mconcat . intersperse (charUtf8 ',') . map renderCell + +Similarly, using /O(n)/ concatentations like '++' or the equivalent 'S.concat' + operations on strict and lazy 'L.ByteString's should be avoided. +The following definition of 'renderString' is also about 20% slower. + +>renderString :: String -> Builder +>renderString cs = charUtf8 $ "\"" ++ concatMap escape cs ++ "\"" +> where +> escape '\\' = "\\" +> escape '\"' = "\\\"" +> escape c = return c + +Apart from removing intermediate data-structures, + encodings can be optimized further by fine-tuning their execution + parameters using the functions in "Data.ByteString.Builder.Extra" and + their \"inner loops\" using the functions in + "Data.ByteString.Builder.Prim". +-} + + +module Data.ByteString.Builder + ( + -- * The Builder type + Builder + + -- * Executing Builders + -- | Internally, 'Builder's are buffer-filling functions. They are + -- executed by a /driver/ that provides them with an actual buffer to + -- fill. Once called with a buffer, a 'Builder' fills it and returns a + -- signal to the driver telling it that it is either done, has filled the + -- current buffer, or wants to directly insert a reference to a chunk of + -- memory. In the last two cases, the 'Builder' also returns a + -- continutation 'Builder' that the driver can call to fill the next + -- buffer. Here, we provide the two drivers that satisfy almost all use + -- cases. See "Data.ByteString.Builder.Extra", for information + -- about fine-tuning them. + , toLazyByteString + , hPutBuilder + + -- * Creating Builders + + -- ** Binary encodings + , byteString + , lazyByteString + , int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- ** Character encodings + + -- *** ASCII (Char7) + -- | The ASCII encoding is a 7-bit encoding. The /Char7/ encoding implemented here + -- works by truncating the Unicode codepoint to 7-bits, prefixing it + -- with a leading 0, and encoding the resulting 8-bits as a single byte. + -- For the codepoints 0-127 this corresponds the ASCII encoding. In + -- "Data.ByteString.Builder.ASCII", we also provide efficient + -- implementations of ASCII-based encodings of numbers (e.g., decimal and + -- hexadecimal encodings). + , char7 + , string7 + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode codepoint + -- to 8-bits and encoding them as a single byte. For the codepoints 0-255 this corresponds + -- to the ISO/IEC 8859-1 encoding. Note that you can also use + -- the functions from "Data.ByteString.Builder.ASCII", as the ASCII encoding + -- and ISO/IEC 8859-1 are equivalent on the codepoints 0-127. + , char8 + , string8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode /all/ Unicode codepoints. We recommend + -- using it always for encoding 'Char's and 'String's unless an application + -- really requires another encoding. Note that you can also use the + -- functions from "Data.ByteString.Builder.ASCII" for UTF-8 encoding, + -- as the ASCII encoding is equivalent to the UTF-8 encoding on the Unicode + -- codepoints 0-127. + , charUtf8 + , stringUtf8 + + , module Data.ByteString.Builder.ASCII + + ) where + +import Data.ByteString.Builder.Internal +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Lazy.Internal as L + +import System.IO (Handle) +import Foreign + +-- HADDOCK only imports +import Data.ByteString.Builder.ASCII (intDec) +import qualified Data.ByteString as S (concat) +import Data.Monoid +import Data.Foldable (foldMap) +import Data.List (intersperse) + + +-- | Execute a 'Builder' and return the generated chunks as a lazy 'L.ByteString'. +-- The work is performed lazy, i.e., only when a chunk of the lazy 'L.ByteString' +-- is forced. +{-# NOINLINE toLazyByteString #-} -- ensure code is shared +toLazyByteString :: Builder -> L.ByteString +toLazyByteString = toLazyByteStringWith + (safeStrategy L.smallChunkSize L.defaultChunkSize) L.Empty + +{- Not yet stable enough. + See note on 'hPut' in Data.ByteString.Builder.Internal +-} + +-- | Output a 'Builder' to a 'Handle'. +-- The 'Builder' is executed directly on the buffer of the 'Handle'. If the +-- buffer is too small (or not present), then it is replaced with a large +-- enough buffer. +-- +-- It is recommended that the 'Handle' is set to binary and +-- 'BlockBuffering' mode. See 'hSetBinaryMode' and 'hSetBuffering'. +-- +-- This function is more efficient than @hPut . 'toLazyByteString'@ because in +-- many cases no buffer allocation has to be done. Moreover, the results of +-- several executions of short 'Builder's are concatenated in the 'Handle's +-- buffer, therefore avoiding unnecessary buffer flushes. +hPutBuilder :: Handle -> Builder -> IO () +hPutBuilder h = hPut h . putBuilder + + +------------------------------------------------------------------------------ +-- Binary encodings +------------------------------------------------------------------------------ + +-- | Encode a single signed byte as-is. +-- +{-# INLINE int8 #-} +int8 :: Int8 -> Builder +int8 = P.primFixed P.int8 + +-- | Encode a single unsigned byte as-is. +-- +{-# INLINE word8 #-} +word8 :: Word8 -> Builder +word8 = P.primFixed P.word8 + + +------------------------------------------------------------------------------ +-- Binary little-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in little endian format. +{-# INLINE int16LE #-} +int16LE :: Int16 -> Builder +int16LE = P.primFixed P.int16LE + +-- | Encode an 'Int32' in little endian format. +{-# INLINE int32LE #-} +int32LE :: Int32 -> Builder +int32LE = P.primFixed P.int32LE + +-- | Encode an 'Int64' in little endian format. +{-# INLINE int64LE #-} +int64LE :: Int64 -> Builder +int64LE = P.primFixed P.int64LE + +-- | Encode a 'Word16' in little endian format. +{-# INLINE word16LE #-} +word16LE :: Word16 -> Builder +word16LE = P.primFixed P.word16LE + +-- | Encode a 'Word32' in little endian format. +{-# INLINE word32LE #-} +word32LE :: Word32 -> Builder +word32LE = P.primFixed P.word32LE + +-- | Encode a 'Word64' in little endian format. +{-# INLINE word64LE #-} +word64LE :: Word64 -> Builder +word64LE = P.primFixed P.word64LE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: Float -> Builder +floatLE = P.primFixed P.floatLE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: Double -> Builder +doubleLE = P.primFixed P.doubleLE + + +------------------------------------------------------------------------------ +-- Binary big-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in big endian format. +{-# INLINE int16BE #-} +int16BE :: Int16 -> Builder +int16BE = P.primFixed P.int16BE + +-- | Encode an 'Int32' in big endian format. +{-# INLINE int32BE #-} +int32BE :: Int32 -> Builder +int32BE = P.primFixed P.int32BE + +-- | Encode an 'Int64' in big endian format. +{-# INLINE int64BE #-} +int64BE :: Int64 -> Builder +int64BE = P.primFixed P.int64BE + +-- | Encode a 'Word16' in big endian format. +{-# INLINE word16BE #-} +word16BE :: Word16 -> Builder +word16BE = P.primFixed P.word16BE + +-- | Encode a 'Word32' in big endian format. +{-# INLINE word32BE #-} +word32BE :: Word32 -> Builder +word32BE = P.primFixed P.word32BE + +-- | Encode a 'Word64' in big endian format. +{-# INLINE word64BE #-} +word64BE :: Word64 -> Builder +word64BE = P.primFixed P.word64BE + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: Float -> Builder +floatBE = P.primFixed P.floatBE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: Double -> Builder +doubleBE = P.primFixed P.doubleBE + +------------------------------------------------------------------------------ +-- ASCII encoding +------------------------------------------------------------------------------ + +-- | Char7 encode a 'Char'. +{-# INLINE char7 #-} +char7 :: Char -> Builder +char7 = P.primFixed P.char7 + +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = P.primMapListFixed P.char7 + +------------------------------------------------------------------------------ +-- ISO/IEC 8859-1 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: Char -> Builder +char8 = P.primFixed P.char8 + +-- | Char8 encode a 'String'. +{-# INLINE string8 #-} +string8 :: String -> Builder +string8 = P.primMapListFixed P.char8 + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: Char -> Builder +charUtf8 = P.primBounded P.charUtf8 + +-- | UTF-8 encode a 'String'. +{-# INLINE stringUtf8 #-} +stringUtf8 :: String -> Builder +stringUtf8 = P.primMapListBounded P.charUtf8 + diff --git a/Data/ByteString/Builder/ASCII.hs b/Data/ByteString/Builder/ASCII.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/ASCII.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} +{-# OPTIONS_HADDOCK hide #-} +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Constructing 'Builder's using ASCII-based encodings. +-- +module Data.ByteString.Builder.ASCII + ( + -- ** ASCII text + -- *** Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + , integerDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + , floatDec + , doubleDec + + -- *** Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest + -- possible representation is used. For example, + -- + -- >>> toLazyByteString (word16Hex 0x0a10) + -- Chunk "a10" Empty + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer, if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- *** Fixed-width hexadecimal numbers + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + + , floatHexFixed + , doubleHexFixed + + , byteStringHex + , lazyByteStringHex + + ) where + +import Data.ByteString as S +import Data.ByteString.Lazy.Internal as L +import Data.ByteString.Builder.Internal (Builder) +import qualified Data.ByteString.Builder.Prim as P + +import Foreign + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + + +-- | Encode a 'String' using 'P.char7'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = P.primMapListFixed P.char7 + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +-- | Decimal encoding of an 'Int8' using the ASCII digits. +-- +-- e.g. +-- +-- > toLazyByteString (int8Dec 42) = "42" +-- > toLazyByteString (int8Dec (-1)) = "-1" +-- +{-# INLINE int8Dec #-} +int8Dec :: Int8 -> Builder +int8Dec = P.primBounded P.int8Dec + +-- | Decimal encoding of an 'Int16' using the ASCII digits. +{-# INLINE int16Dec #-} +int16Dec :: Int16 -> Builder +int16Dec = P.primBounded P.int16Dec + +-- | Decimal encoding of an 'Int32' using the ASCII digits. +{-# INLINE int32Dec #-} +int32Dec :: Int32 -> Builder +int32Dec = P.primBounded P.int32Dec + +-- | Decimal encoding of an 'Int64' using the ASCII digits. +{-# INLINE int64Dec #-} +int64Dec :: Int64 -> Builder +int64Dec = P.primBounded P.int64Dec + +-- | Decimal encoding of an 'Int' using the ASCII digits. +{-# INLINE intDec #-} +intDec :: Int -> Builder +intDec = P.primBounded P.intDec + +-- | /Currently slow./ Decimal encoding of an 'Integer' using the ASCII digits. +{-# INLINE integerDec #-} +integerDec :: Integer -> Builder +integerDec = string7 . show + + +-- Unsigned integers +-------------------- + +-- | Decimal encoding of a 'Word8' using the ASCII digits. +{-# INLINE word8Dec #-} +word8Dec :: Word8 -> Builder +word8Dec = P.primBounded P.word8Dec + +-- | Decimal encoding of a 'Word16' using the ASCII digits. +{-# INLINE word16Dec #-} +word16Dec :: Word16 -> Builder +word16Dec = P.primBounded P.word16Dec + +-- | Decimal encoding of a 'Word32' using the ASCII digits. +{-# INLINE word32Dec #-} +word32Dec :: Word32 -> Builder +word32Dec = P.primBounded P.word32Dec + +-- | Decimal encoding of a 'Word64' using the ASCII digits. +{-# INLINE word64Dec #-} +word64Dec :: Word64 -> Builder +word64Dec = P.primBounded P.word64Dec + +-- | Decimal encoding of a 'Word' using the ASCII digits. +{-# INLINE wordDec #-} +wordDec :: Word -> Builder +wordDec = P.primBounded P.wordDec + + +-- Floating point numbers +------------------------- + +-- TODO: Use Bryan O'Sullivan's double-conversion package to speed it up. + +-- | /Currently slow./ Decimal encoding of an IEEE 'Float'. +{-# INLINE floatDec #-} +floatDec :: Float -> Builder +floatDec = string7 . show + +-- | /Currently slow./ Decimal encoding of an IEEE 'Double'. +{-# INLINE doubleDec #-} +doubleDec :: Double -> Builder +doubleDec = string7 . show + + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +-- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters. +{-# INLINE word8Hex #-} +word8Hex :: Word8 -> Builder +word8Hex = P.primBounded P.word8Hex + +-- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters. +{-# INLINE word16Hex #-} +word16Hex :: Word16 -> Builder +word16Hex = P.primBounded P.word16Hex + +-- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters. +{-# INLINE word32Hex #-} +word32Hex :: Word32 -> Builder +word32Hex = P.primBounded P.word32Hex + +-- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters. +{-# INLINE word64Hex #-} +word64Hex :: Word64 -> Builder +word64Hex = P.primBounded P.word64Hex + +-- | Shortest hexadecimal encoding of a 'Word' using lower-case characters. +{-# INLINE wordHex #-} +wordHex :: Word -> Builder +wordHex = P.primBounded P.wordHex + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: Int8 -> Builder +int8HexFixed = P.primFixed P.int8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: Int16 -> Builder +int16HexFixed = P.primFixed P.int16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: Int32 -> Builder +int32HexFixed = P.primFixed P.int32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: Int64 -> Builder +int64HexFixed = P.primFixed P.int64HexFixed + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: Word8 -> Builder +word8HexFixed = P.primFixed P.word8HexFixed + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: Word16 -> Builder +word16HexFixed = P.primFixed P.word16HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: Word32 -> Builder +word32HexFixed = P.primFixed P.word32HexFixed + +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: Word64 -> Builder +word64HexFixed = P.primFixed P.word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: Float -> Builder +floatHexFixed = P.primFixed P.floatHexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: Double -> Builder +doubleHexFixed = P.primFixed P.doubleHexFixed + +-- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding. +{-# NOINLINE byteStringHex #-} -- share code +byteStringHex :: S.ByteString -> Builder +byteStringHex = P.primMapByteStringFixed P.word8HexFixed + +-- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding. +{-# NOINLINE lazyByteStringHex #-} -- share code +lazyByteStringHex :: L.ByteString -> Builder +lazyByteStringHex = P.primMapLazyByteStringFixed P.word8HexFixed diff --git a/Data/ByteString/Builder/Extra.hs b/Data/ByteString/Builder/Extra.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Extra.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Extra functions for creating and executing 'Builder's. They are intended +-- for application-specific fine-tuning the performance of 'Builder's. +-- +----------------------------------------------------------------------------- +module Data.ByteString.Builder.Extra + ( + -- * Execution strategies + toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , smallChunkSize + , defaultChunkSize + + -- * Controlling chunk boundaries + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , flush + + -- * Low level execution + , BufferWriter + , Next(..) + , runBuilder + + -- * Host-specific binary encodings + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + + +import Data.ByteString.Builder.Internal + ( Builder, toLazyByteStringWith + , AllocationStrategy, safeStrategy, untrimmedStrategy + , smallChunkSize, defaultChunkSize, flush + , byteStringCopy, byteStringInsert, byteStringThreshold + , lazyByteStringCopy, lazyByteStringInsert, lazyByteStringThreshold ) + +import qualified Data.ByteString.Builder.Internal as I +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + + +import Foreign + +------------------------------------------------------------------------------ +-- Builder execution public API +------------------------------------------------------------------------------ + +-- | A 'BufferWriter' represents the result of running a 'Builder'. +-- It unfolds as a sequence of chunks of data. These chunks come in two forms: +-- +-- * an IO action for writing the Builder's data into a user-supplied memory +-- buffer. +-- +-- * a pre-existing chunks of data represented by a strict 'ByteString' +-- +-- While this is rather low level, it provides you with full flexibility in +-- how the data is written out. +-- +-- The 'BufferWriter' itself is an IO action: you supply it with a buffer +-- (as a pointer and length) and it will write data into the buffer. +-- It returns a number indicating how many bytes were actually written +-- (which can be @0@). It also returns a 'Next' which describes what +-- comes next. +-- +type BufferWriter = Ptr Word8 -> Int -> IO (Int, Next) + +-- | After running a 'BufferWriter' action there are three possibilities for +-- what comes next: +-- +data Next = + -- | This means we're all done. All the builder data has now been written. + Done + + -- | This indicates that there may be more data to write. It + -- gives you the next 'BufferWriter' action. You should call that action + -- with an appropriate buffer. The int indicates the /minimum/ buffer size + -- required by the next 'BufferWriter' action. That is, if you call the next + -- action you /must/ supply it with a buffer length of at least this size. + | More !Int BufferWriter + + -- | In addition to the data that has just been written into your buffer + -- by the 'BufferWriter' action, it gives you a pre-existing chunk + -- of data as a 'S.ByteString'. It also gives you the following 'BufferWriter' + -- action. It is safe to run this following action using a buffer with as + -- much free space as was left by the previous run action. + | Chunk !S.ByteString BufferWriter + +-- | Turn a 'Builder' into its initial 'BufferWriter' action. +-- +runBuilder :: Builder -> BufferWriter +runBuilder = run . I.runBuilder + where + run :: I.BuildStep () -> BufferWriter + run step = \buf len -> do + sig <- step (I.BufferRange buf (buf `plusPtr` len)) + case sig of + I.Done endPtr () -> + let !wc = bytesWritten buf endPtr + next = Done + in return (wc, next) + + I.BufferFull minReq endPtr step' -> + let !wc = bytesWritten buf endPtr + next = More minReq (run step') + in return (wc, next) + + I.InsertChunks endPtr _ lbsc step' -> + let !wc = bytesWritten buf endPtr + next = case lbsc L.Empty of + L.Empty -> More (len - wc) (run step') + L.Chunk c cs -> Chunk c (yieldChunks step' cs) + in return (wc, next) + + yieldChunks :: I.BuildStep () -> L.ByteString -> BufferWriter + yieldChunks step' cs = \buf len -> + case cs of + L.Empty -> run step' buf len + L.Chunk c cs' -> + let wc = 0 + next = Chunk c (yieldChunks step' cs') + in return (wc, next) + + bytesWritten startPtr endPtr = endPtr `minusPtr` startPtr + + +------------------------------------------------------------------------------ +-- Host-specific encodings +------------------------------------------------------------------------------ + +-- | Encode a single native machine 'Int'. The 'Int' is encoded in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or int sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: Int -> Builder +intHost = P.primFixed P.intHost + +-- | Encode a 'Int16' in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: Int16 -> Builder +int16Host = P.primFixed P.int16Host + +-- | Encode a 'Int32' in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: Int32 -> Builder +int32Host = P.primFixed P.int32Host + +-- | Encode a 'Int64' in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: Int64 -> Builder +int64Host = P.primFixed P.int64Host + +-- | Encode a single native machine 'Word'. The 'Word' is encoded in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: Word -> Builder +wordHost = P.primFixed P.wordHost + +-- | Encode a 'Word16' in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: Word16 -> Builder +word16Host = P.primFixed P.word16Host + +-- | Encode a 'Word32' in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: Word32 -> Builder +word32Host = P.primFixed P.word32Host + +-- | Encode a 'Word64' in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: Word64 -> Builder +word64Host = P.primFixed P.word64Host + +-- | Encode a 'Float' in native host order. Values encoded this way are not +-- portable to different endian machines, without conversion. +{-# INLINE floatHost #-} +floatHost :: Float -> Builder +floatHost = P.primFixed P.floatHost + +-- | Encode a 'Double' in native host order. +{-# INLINE doubleHost #-} +doubleHost :: Double -> Builder +doubleHost = P.primFixed P.doubleHost + diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Internal.hs @@ -0,0 +1,868 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, Rank2Types #-} +{-# OPTIONS_HADDOCK hide #-} +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : unstable, private +-- Portability : GHC +-- +-- *Warning:* this module is internal. If you find that you need it then please +-- contact the maintainers and explain what you are trying to do and discuss +-- what you would need in the public API. It is important that you do this as +-- the module may not be exposed at all in future releases. +-- +-- Core types and functions for the 'Builder' monoid and its generalization, +-- the 'Put' monad. +-- +-- The design of the 'Builder' monoid is optimized such that +-- +-- 1. buffers of arbitrary size can be filled as efficiently as possible and +-- +-- 2. sequencing of 'Builder's is as cheap as possible. +-- +-- We achieve (1) by completely handing over control over writing to the buffer +-- to the 'BuildStep' implementing the 'Builder'. This 'BuildStep' is just told +-- the start and the end of the buffer (represented as a 'BufferRange'). Then, +-- the 'BuildStep' can write to as big a prefix of this 'BufferRange' in any +-- way it desires. If the 'BuildStep' is done, the 'BufferRange' is full, or a +-- long sequence of bytes should be inserted directly, then the 'BuildStep' +-- signals this to its caller using a 'BuildSignal'. +-- +-- We achieve (2) by requiring that every 'Builder' is implemented by a +-- 'BuildStep' that takes a continuation 'BuildStep', which it calls with the +-- updated 'BufferRange' after it is done. Therefore, only two pointers have +-- to be passed in a function call to implement concatenation of 'Builder's. +-- Moreover, many 'Builder's are completely inlined, which enables the compiler +-- to sequence them without a function call and with no boxing at all. +-- +-- This design gives the implementation of a 'Builder' full access to the 'IO' +-- monad. Therefore, utmost care has to be taken to not overwrite anything +-- outside the given 'BufferRange's. Moreover, further care has to be taken to +-- ensure that 'Builder's and 'Put's are referentially transparent. See the +-- comments of the 'builder' and 'put' functions for further information. +-- Note that there are /no safety belts/ at all, when implementing a 'Builder' +-- using an 'IO' action: you are writing code that might enable the next +-- buffer-overflow attack on a Haskell server! +-- +module Data.ByteString.Builder.Internal ( + + -- * Build signals and steps + BufferRange(..) + , LazyByteStringC + + , BuildSignal(..) + , BuildStep + + , done + , bufferFull + , insertChunks + + , fillWithBuildStep + + -- * The Builder monoid + , Builder + , builder + , runBuilder + , runBuilderWith + + -- ** Primitive combinators + , empty + , append + , flush + , ensureFree + + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , lazyByteStringC + + , maximalCopySize + , byteString + , lazyByteString + + -- ** Execution strategies + , toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , L.smallChunkSize + , L.defaultChunkSize + + -- * The Put monad + , Put + , put + , runPut + , hPut + + -- ** Streams of chunks interleaved with IO + , ChunkIOStream(..) + , buildStepToCIOS + , ciosToLazyByteString + + -- ** Conversion to and from Builders + , putBuilder + , fromPut + + -- ** Lifting IO actions + -- , putLiftIO + +) where + +import Control.Applicative (Applicative(..), (<$>)) + +import Data.Monoid +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Buffer (Buffer(..), newByteBuffer) +import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) +import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) +import System.IO (hFlush, BufferMode(..)) +import Data.IORef +#else +import qualified Data.ByteString.Lazy as L +#endif +import System.IO (Handle) + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + + +type LazyByteStringC = L.ByteString -> L.ByteString + +-- | A range of bytes in a buffer represented by the pointer to the first byte +-- of the range and the pointer to the first byte /after/ the range. +data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range + {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range + + +------------------------------------------------------------------------------ +-- Build signals +------------------------------------------------------------------------------ + +-- | 'BuildStep's may assume that they are called at most once. However, +-- they must not execute any function that may rise an async. exception, +-- as this would invalidate the code of 'hPut' below. +type BuildStep a = BufferRange -> IO (BuildSignal a) + +-- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are +-- exactly three signals: 'done', 'bufferFull', and 'insertChunks'. +data BuildSignal a = + Done {-# UNPACK #-} !(Ptr Word8) a + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + !(BuildStep a) + | InsertChunks + {-# UNPACK #-} !(Ptr Word8) + {-# UNPACK #-} !Int64 -- size of bytes in continuation + LazyByteStringC + !(BuildStep a) + +-- | Signal that the current 'BuildStep' is done and has computed a value. +{-# INLINE done #-} +done :: Ptr Word8 -- ^ Next free byte in current 'BufferRange' + -> a -- ^ Computed value + -> BuildSignal a +done = Done + +-- | Signal that the current buffer is full. +{-# INLINE bufferFull #-} +bufferFull :: Int + -- ^ Minimal size of next 'BufferRange'. + -> Ptr Word8 + -- ^ Next free byte in current 'BufferRange'. + -> BuildStep a + -- ^ 'BuildStep' to run on the next 'BufferRange'. This 'BuildStep' + -- may assume that it is called with a 'BufferRange' of at least the + -- required minimal size; i.e., the caller of this 'BuildStep' must + -- guarantee this. + -> BuildSignal a +bufferFull = BufferFull + +-- TODO: Decide whether we should inline the bytestring constructor. +-- Therefore, making builders independent of strict bytestrings. + +-- | Signal that several chunks should be inserted directly. +{-# INLINE insertChunks #-} +insertChunks :: Ptr Word8 + -- ^ Next free byte in current 'BufferRange' + -> Int64 + -- ^ Number of bytes in 'L.ByteString' continuation. + -> (L.ByteString -> L.ByteString) + -- ^ Chunks to insert. + -> BuildStep a + -- ^ 'BuildStep' to run on next 'BufferRange' + -> BuildSignal a +insertChunks = InsertChunks + +-- | Fill a 'BufferRange' using a 'BuildStep'. +{-# INLINE fillWithBuildStep #-} +fillWithBuildStep + :: BuildStep a + -- ^ Build step to use for filling the 'BufferRange'. + -> (Ptr Word8 -> a -> IO b) + -- ^ Handling the 'done' signal + -> (Ptr Word8 -> Int -> BuildStep a -> IO b) + -- ^ Handling the 'bufferFull' signal + -> (Ptr Word8 -> Int64 -> LazyByteStringC -> BuildStep a -> IO b) + -- ^ Handling the 'insertChunks' signal + -> BufferRange + -- ^ Buffer range to fill. + -> IO b + -- ^ Value computed by filling this 'BufferRange'. +fillWithBuildStep step fDone fFull fChunk !br = do + signal <- step br + case signal of + Done op x -> fDone op x + BufferFull minSize op nextStep -> fFull op minSize nextStep + InsertChunks op len lbsC nextStep -> fChunk op len lbsC nextStep + + + +------------------------------------------------------------------------------ +-- The 'Builder' monoid +------------------------------------------------------------------------------ + +-- | 'Builder's denote sequences of bytes. +-- They are 'Monoid's where +-- 'mempty' is the zero-length sequence and +-- 'mappend' is concatenation, which runs in /O(1)/. +newtype Builder = Builder (forall r. BuildStep r -> BuildStep r) + +-- | Construct a 'Builder'. In contrast to 'BuildStep's, 'Builder's are +-- referentially transparent. +{-# INLINE builder #-} +builder :: (forall r. BuildStep r -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' once its done, and signals its caller how + -- to proceed using 'done', 'bufferFull', or 'insertChunk'. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times must result in the same sequence of bytes being + -- written. If you need mutable state, then you must allocate it newly + -- upon each call of this function. Moroever, this function must call + -- the continuation once its done. Otherwise, concatenation of + -- 'Builder's does not work. Finally, this function must write to all + -- bytes that it claims it has written. Otherwise, the resulting + -- 'Builder' is not guaranteed to be referentially transparent and + -- sensitive data might leak. + -> Builder +builder = Builder + +-- | Run a 'Builder'. +{-# INLINE runBuilder #-} +runBuilder :: Builder -- ^ 'Builder' to run + -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this + -- 'Builder' and signals 'done' upon completion. +runBuilder (Builder b) = b $ \(BufferRange op _) -> return $ done op () + +-- | Run a 'Builder'. +{-# INLINE runBuilderWith #-} +runBuilderWith :: Builder -- ^ 'Builder' to run + -> BuildStep a -- ^ Continuation 'BuildStep' + -> BuildStep a +runBuilderWith (Builder b) = b + +-- | The 'Builder' denoting a zero-length sequence of bytes. This function is +-- only exported for use in rewriting rules. Use 'mempty' otherwise. +{-# INLINE[1] empty #-} +empty :: Builder +empty = Builder id + +-- | Concatenate two 'Builder's. This function is only exported for use in rewriting +-- rules. Use 'mappend' otherwise. +{-# INLINE[1] append #-} +append :: Builder -> Builder -> Builder +append (Builder b1) (Builder b2) = Builder $ b1 . b2 + +instance Monoid Builder where + {-# INLINE mempty #-} + mempty = empty + {-# INLINE mappend #-} + mappend = append + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty + +instance Show Builder where + show = show . showBuilder + +{-# NOINLINE showBuilder #-} -- ensure code is shared +showBuilder :: Builder -> L.ByteString +showBuilder = toLazyByteStringWith + (safeStrategy L.smallChunkSize L.smallChunkSize) L.Empty + + +-- | Flush the current buffer. This introduces a chunk boundary. +-- +{-# INLINE flush #-} +flush :: Builder +flush = builder step + where + step k !(BufferRange op _) = return $ insertChunks op 0 id k + + +------------------------------------------------------------------------------ +-- Put +------------------------------------------------------------------------------ + +-- | A 'Put' action denotes a computation of a value that writes a stream of +-- bytes as a side-effect. 'Put's are strict in their side-effect; i.e., the +-- stream of bytes will always be written before the computed value is +-- returned. +-- +-- 'Put's are a generalization of 'Builder's. They are used when values need to +-- be returned during the computation of a stream of bytes. For example, when +-- performing a block-based encoding of 'S.ByteString's like Base64 encoding, +-- there might be a left-over partial block. Using the 'Put' monad, this +-- partial block can be returned after the complete blocks have been encoded. +-- Then, in a later step when more input is known, this partial block can be +-- completed and also encoded. +-- +-- @Put ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' +-- and 'fromPut' convert between these two types. Where possible, you should +-- use 'Builder's, as they are slightly cheaper than 'Put's because they do not +-- carry a computed value. +newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } + +-- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are +-- referentially transparent in the sense that sequencing the same 'Put' +-- multiple times yields every time the same value with the same side-effect. +{-# INLINE put #-} +put :: (forall r. (a -> BuildStep r) -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' and its computed value once its done, and + -- signals its caller how to proceed using 'done', 'bufferFull', or + -- 'insertChunk'. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times must result in the same sequence of bytes being + -- written and the same value being computed. If you need mutable state, + -- then you must allocate it newly upon each call of this function. + -- Moroever, this function must call the continuation once its done. + -- Otherwise, monadic sequencing of 'Put's does not work. Finally, this + -- function must write to all bytes that it claims it has written. + -- Otherwise, the resulting 'Put' is not guaranteed to be referentially + -- transparent and sensitive data might leak. + -> Put a +put = Put + +-- | Run a 'Put'. +{-# INLINE runPut #-} +runPut :: Put a -- ^ Put to run + -> BuildStep a -- ^ 'BuildStep' that first writes the byte stream of + -- this 'Put' and then yields the computed value using + -- the 'done' signal. +runPut (Put p) = p $ \x (BufferRange op _) -> return $ Done op x + +instance Functor Put where + fmap f p = Put $ \k -> unPut p (\x -> k (f x)) + {-# INLINE fmap #-} + +instance Applicative Put where + {-# INLINE pure #-} + pure x = Put $ \k -> k x + {-# INLINE (<*>) #-} + Put f <*> Put a = Put $ \k -> f (\f' -> a (\a' -> k (f' a'))) +#if MIN_VERSION_base(4,2,0) + {-# INLINE (<*) #-} + Put a <* Put b = Put $ \k -> a (\a' -> b (\_ -> k a')) + {-# INLINE (*>) #-} + Put a *> Put b = Put $ \k -> a (\_ -> b k) +#endif + +instance Monad Put where + {-# INLINE return #-} + return x = Put $ \k -> k x + {-# INLINE (>>=) #-} + Put m >>= f = Put $ \k -> m (\m' -> unPut (f m') k) + {-# INLINE (>>) #-} + Put m >> Put n = Put $ \k -> m (\_ -> n k) + + +-- Conversion between Put and Builder +------------------------------------- + +-- | Run a 'Builder' as a side-effect of a @Put ()@ action. +{-# INLINE putBuilder #-} +putBuilder :: Builder -> Put () +putBuilder (Builder b) = Put $ \k -> b (k ()) + +-- | Convert a @Put ()@ action to a 'Builder'. +{-# INLINE fromPut #-} +fromPut :: Put () -> Builder +fromPut (Put p) = Builder $ \k -> p (\_ -> k) + + +-- Lifting IO actions +--------------------- + +{- +-- | Lift an 'IO' action to a 'Put' action. +{-# INLINE putLiftIO #-} +putLiftIO :: IO a -> Put a +putLiftIO io = put $ \k br -> io >>= (`k` br) +-} + + +------------------------------------------------------------------------------ +-- Executing a Put directly on a buffered Handle +------------------------------------------------------------------------------ + +-- | Run a 'Put' action redirecting the produced output to a 'Handle'. +-- +-- The output is buffered using the 'Handle's associated buffer. If this +-- buffer is too small to execute one step of the 'Put' action, then +-- it is replaced with a large enough buffer. +hPut :: forall a. Handle -> Put a -> IO a +#if __GLASGOW_HASKELL__ >= 611 +hPut h p = do + fillHandle 1 (runPut p) + where + fillHandle :: Int -> BuildStep a -> IO a + fillHandle !minFree step = do + next <- wantWritableHandle "hPut" h fillHandle_ + next + where + -- | We need to return an inner IO action that is executed outside + -- the lock taken on the Handle for two reasons: + -- + -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that + -- we should never do any side-effecting operations before + -- an interruptible operation that may raise an async. exception + -- as long as we are inside 'wantWritableHandle' and the like. + -- We possibly run the interuptible 'flushWriteBuffer' right at + -- the start of 'fillHandle', hence entering it a second time is + -- not safe, as it could lead to a 'BuildStep' being run twice. + -- + -- 2. We use the 'S.hPut' function to also write to the handle. + -- This function tries to take the same lock taken by + -- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut' + -- inside 'wantWritableHandle'. + -- + fillHandle_ :: Handle__ -> IO (IO a) + fillHandle_ h_ = do + makeSpace =<< readIORef refBuf + fillBuffer =<< readIORef refBuf + where + refBuf = haByteBuffer h_ + freeSpace buf = bufSize buf - bufR buf + + makeSpace buf + | bufSize buf < minFree = do + flushWriteBuffer h_ + s <- bufState <$> readIORef refBuf + newByteBuffer minFree s >>= writeIORef refBuf + + | freeSpace buf < minFree = flushWriteBuffer h_ + | otherwise = +#if __GLASGOW_HASKELL__ >= 613 + return () +#else + -- required for ghc-6.12 + flushWriteBuffer h_ +#endif + + fillBuffer buf + | freeSpace buf < minFree = + error $ unlines + [ "Data.ByteString.Builder.Internal.hPut: internal error." + , " Not enough space after flush." + , " required: " ++ show minFree + , " free: " ++ show (freeSpace buf) + ] + | otherwise = do + let !br = BufferRange op (pBuf `plusPtr` bufSize buf) + res <- fillWithBuildStep step doneH fullH insertChunksH br + touchForeignPtr fpBuf + return res + where + fpBuf = bufRaw buf + pBuf = unsafeForeignPtrToPtr fpBuf + op = pBuf `plusPtr` bufR buf + + {-# INLINE updateBufR #-} + updateBufR op' = do + let !off' = op' `minusPtr` pBuf + !buf' = buf {bufR = off'} + writeIORef refBuf buf' + + doneH op' x = do + updateBufR op' + -- We must flush if this Handle is set to NoBuffering. + -- If it is set to LineBuffering, be conservative and + -- flush anyway (we didn't check for newlines in the data). + -- Flushing must happen outside this 'wantWriteableHandle' + -- due to the possible async. exception. + case haBufferMode h_ of + BlockBuffering _ -> return $ return x + _line_or_no_buffering -> return $ hFlush h >> return x + + fullH op' minSize nextStep = do + updateBufR op' + return $ fillHandle minSize nextStep + -- 'fillHandle' will flush the buffer (provided there is + -- really less than 'minSize' space left) before executing + -- the 'nextStep'. + + insertChunksH op' _ lbsC nextStep = do + updateBufR op' + return $ do + L.foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) + (lbsC L.Empty) + fillHandle 1 nextStep +#else +hPut h p = + go =<< buildStepToCIOS strategy (return . Finished) (runPut p) + where + go (Finished k) = return k + go (Yield1 bs io) = S.hPut h bs >> io >>= go + go (YieldC _ lbsC io) = L.hPut h (lbsC L.Empty) >> io >>= go + strategy = untrimmedStrategy L.smallChunkSize L.defaultChunkSize +#endif + +------------------------------------------------------------------------------ +-- ByteString insertion / controlling chunk boundaries +------------------------------------------------------------------------------ + +-- Raw memory +------------- + +-- | Ensure that there are at least 'n' free bytes for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + builder step + where + step k br@(BufferRange op ope) + | ope `minusPtr` op < minFree = return $ bufferFull minFree op k + | otherwise = k br + +-- | Copy the bytes from a 'BufferRange' into the output stream. +{-# INLINE bytesCopyStep #-} +bytesCopyStep :: BufferRange -- ^ Input 'BufferRange'. + -> BuildStep a -> BuildStep a +bytesCopyStep !(BufferRange ip0 ipe) k = + go ip0 + where + go !ip !(BufferRange op ope) + | inpRemaining <= outRemaining = do + copyBytes op ip inpRemaining + let !br' = BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + copyBytes op ip outRemaining + let !ip' = ip `plusPtr` outRemaining + return $ bufferFull 1 ope (go ip') + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe `minusPtr` ip + + + +-- Strict ByteStrings +------------------------------------------------------------------------------ + + +-- | Construct a 'Builder' that copies the strict 'S.ByteString's, if it is +-- smaller than the treshold, and inserts it directly otherwise. +-- +-- For example, @byteStringThreshold 1024@ copies strict 'S.ByteString's whose size +-- is less or equal to 1kb, and inserts them directly otherwise. This implies +-- that the average chunk-size of the generated lazy 'L.ByteString' may be as +-- low as 513 bytes, as there could always be just a single byte between the +-- directly inserted 1025 byte, strict 'S.ByteString's. +-- +{-# INLINE byteStringThreshold #-} +byteStringThreshold :: Int -> S.ByteString -> Builder +byteStringThreshold maxCopySize = + \bs -> builder $ step bs + where + step !bs@(S.PS _ _ len) !k br@(BufferRange !op _) + | len <= maxCopySize = byteStringCopyStep bs k br + | otherwise = + return $! insertChunks op (fromIntegral len) (L.chunk bs) k + +-- | Construct a 'Builder' that copies the strict 'S.ByteString'. +-- +-- Use this function to create 'Builder's from smallish (@<= 4kb@) +-- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not +-- shared with the chunks generated by the 'Builder'. +-- +{-# INLINE byteStringCopy #-} +byteStringCopy :: S.ByteString -> Builder +byteStringCopy = \bs -> builder $ byteStringCopyStep bs + +{-# INLINE byteStringCopyStep #-} +byteStringCopyStep :: S.ByteString -> BuildStep a -> BuildStep a +byteStringCopyStep (S.PS ifp ioff isize) !k0 = + bytesCopyStep (BufferRange ip ipe) k + where + ip = unsafeForeignPtrToPtr ifp `plusPtr` ioff + ipe = ip `plusPtr` isize + k br = do touchForeignPtr ifp -- input consumed: OK to release here + k0 br + +-- | Construct a 'Builder' that always inserts the strict 'S.ByteString' +-- directly as a chunk. +-- +-- This implies flushing the output buffer, even if it contains just +-- a single byte. You should therefore use 'byteStringInsert' only for large +-- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too +-- fragmented to be processed efficiently afterwards. +-- +{-# INLINE byteStringInsert #-} +byteStringInsert :: S.ByteString -> Builder +byteStringInsert = + \bs -> builder $ step bs + where + step !bs k !br@(BufferRange op _) + | S.null bs = k br + | otherwise = + return $ insertChunks op (fromIntegral $ S.length bs) (L.Chunk bs) k + + +-- Lazy bytestrings +------------------------------------------------------------------------------ + +-- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold' +-- for each chunk of the lazy 'L.ByteString'. +-- +{-# INLINE lazyByteStringThreshold #-} +lazyByteStringThreshold :: Int -> L.ByteString -> Builder +lazyByteStringThreshold maxCopySize = + L.foldrChunks (\bs b -> byteStringThreshold maxCopySize bs `mappend` b) mempty + -- TODO: We could do better here. Currently, Large, Small, Large, leads to + -- an unnecessary copy of the 'Small' chunk. + +-- | Construct a 'Builder' that copies the lazy 'L.ByteString'. +-- +{-# INLINE lazyByteStringCopy #-} +lazyByteStringCopy :: L.ByteString -> Builder +lazyByteStringCopy = + L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty + + +-- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString' +-- directly. +-- +{-# INLINE lazyByteStringInsert #-} +lazyByteStringInsert :: L.ByteString -> Builder +lazyByteStringInsert = + \lbs -> builder $ step lbs + where + step L.Empty k br = k br + step lbs k (BufferRange op _) = case go 0 id lbs of + (n, lbsC) -> return $ insertChunks op n lbsC k + + go !n lbsC L.Empty = (n, lbsC) + go !n lbsC (L.Chunk bs lbs) = + go (n + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) lbs + + +-- | Create a 'Builder' denoting the same sequence of bytes as a strict +-- 'S.ByteString'. +-- The 'Builder' inserts large 'S.ByteString's directly, but copies small ones +-- to ensure that the generated chunks are large on average. +-- +{-# INLINE byteString #-} +byteString :: S.ByteString -> Builder +byteString = byteStringThreshold maximalCopySize + +-- | Create a 'Builder' denoting the same sequence of bytes as a lazy +-- 'S.ByteString'. +-- The 'Builder' inserts large chunks of the lazy 'L.ByteString' directly, +-- but copies small ones to ensure that the generated chunks are large on +-- average. +-- +{-# INLINE lazyByteString #-} +lazyByteString :: L.ByteString -> Builder +lazyByteString = lazyByteStringThreshold maximalCopySize +-- FIXME: also insert the small chunk for [large,small,large] directly. +-- Perhaps it makes even sense to concatenate the small chunks in +-- [large,small,small,small,large] and insert them directly afterwards to avoid +-- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency +-- => no good! + +-- | The maximal size of a 'S.ByteString' that is copied. +-- @2 * 'L.smallChunkSize'@ to guarantee that on average a chunk is of +-- 'L.smallChunkSize'. +maximalCopySize :: Int +maximalCopySize = 2 * L.smallChunkSize + +-- LazyByteStringC: difference lists of lazy bytestrings +-------------------------------------------------------- + +-- | Insert a 'LazyByteStringC' of the given size directly. +{-# INLINE lazyByteStringC #-} +lazyByteStringC :: Int64 -> LazyByteStringC -> Builder +lazyByteStringC n lbsC = + builder $ \k (BufferRange op _) -> return $ insertChunks op n lbsC k + +------------------------------------------------------------------------------ +-- Builder execution +------------------------------------------------------------------------------ + +-- | A buffer allocation strategy for executing 'Builder's. + +-- The strategy +-- +-- > 'AllocationStrategy' firstBufSize bufSize trim +-- +-- states that the first buffer is of size @firstBufSize@, all following buffers +-- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should +-- be trimmed iff @trim k n@ is 'True'. +data AllocationStrategy = AllocationStrategy + {-# UNPACK #-} !Int -- size of first buffer + {-# UNPACK #-} !Int -- size of successive buffers + (Int -> Int -> Bool) -- trim + +-- | Sanitize a buffer size; i.e., make it at least the size of a 'Int'. +{-# INLINE sanitize #-} +sanitize :: Int -> Int +sanitize = max (sizeOf (undefined :: Int)) + +-- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- discarded right after they are generated. For example, if you just generate +-- them to write them to a network socket. +{-# INLINE untrimmedStrategy #-} +untrimmedStrategy :: Int -- ^ Size of the first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that does not trim any of the + -- filled buffers before converting it to a chunk. +untrimmedStrategy firstSize bufSize = + AllocationStrategy (sanitize firstSize) (sanitize bufSize) (\_ _ -> False) + + +-- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- likely to survive one garbage collection. This strategy trims buffers +-- that are filled less than half in order to avoid spilling too much memory. +{-# INLINE safeStrategy #-} +safeStrategy :: Int -- ^ Size of first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that guarantees that at least half + -- of the allocated memory is used for live data +safeStrategy firstSize bufSize = + AllocationStrategy (sanitize firstSize) (sanitize bufSize) + (\used size -> 2*used < size) + +-- | Execute a 'Builder' with custom execution parameters. +-- +-- This function is forced to be inlined to allow fusing with the allocation +-- strategy despite its rather heavy code-size. We therefore recommend +-- that you introduce a top-level function once you have fixed your strategy. +-- This avoids unnecessary code duplication. +-- For example, the default 'Builder' execution function 'toLazyByteString' is +-- defined as follows. +-- +-- @ +-- {-# NOINLINE toLazyByteString #-} +-- toLazyByteString = +-- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') empty +-- @ +-- +-- where @empty@ is the zero-length lazy 'L.ByteString'. +-- +-- In most cases, the parameters used by 'toLazyByteString' give good +-- performance. A sub-performing case of 'toLazyByteString' is executing short +-- (<128 bytes) 'Builder's. In this case, the allocation overhead for the first +-- 4kb buffer and the trimming cost dominate the cost of executing the +-- 'Builder'. You can avoid this problem using +-- +-- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) empty +-- +-- This reduces the allocation and trimming overhead, as all generated +-- 'L.ByteString's fit into the first buffer and there is no trimming +-- required, if more than 64 bytes are written. +-- +{-# INLINE toLazyByteStringWith #-} +toLazyByteStringWith + :: AllocationStrategy + -- ^ Buffer allocation strategy to use + -> L.ByteString + -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy + -- 'L.ByteString' + -> Builder + -- ^ Builder to execute + -> L.ByteString + -- ^ Resulting lazy 'L.ByteString' +toLazyByteStringWith strategy k b = + ciosToLazyByteString k $ unsafePerformIO $ + buildStepToCIOS strategy (return . Finished) (runBuilder b) + +-- | A stream of non-empty chunks interleaved with 'IO'. +data ChunkIOStream a = + Finished a + | Yield1 {-# UNPACK #-} !S.ByteString (IO (ChunkIOStream a)) + | YieldC {-# UNPACK #-} !Int64 LazyByteStringC (IO (ChunkIOStream a)) + +{-# INLINE ciosToLazyByteString #-} +ciosToLazyByteString :: L.ByteString -> ChunkIOStream () -> L.ByteString +ciosToLazyByteString k = go + where + go (Finished _) = k + go (Yield1 bs io) = L.Chunk bs $ unsafePerformIO (go <$> io) + go (YieldC _ lbsC io) = lbsC $ unsafePerformIO (go <$> io) + +{-# INLINE buildStepToCIOS #-} +buildStepToCIOS + :: AllocationStrategy -- ^ Buffer allocation strategy to use + -> (a -> IO (ChunkIOStream b)) -- ^ Continuation stream constructor. + -> BuildStep a -- ^ 'Put' to execute + -> IO (ChunkIOStream b) +buildStepToCIOS (AllocationStrategy firstSize bufSize trim) k = + \step -> fillNew step firstSize + where + fillNew !step0 !size = do + S.mallocByteString size >>= fill step0 + where + fill !step !fpbuf = do + res <- fillWithBuildStep step doneH fullH insertChunksH br + touchForeignPtr fpbuf + return res + where + op = unsafeForeignPtrToPtr fpbuf -- safe due to mkCIOS + pe = op `plusPtr` size + br = BufferRange op pe + + doneH op' x = wrapChunk op' (const $ k x) + + fullH op' minSize nextStep = + wrapChunk op' (const $ fillNew nextStep (max minSize bufSize)) + + insertChunksH op' n lbsC nextStep = + wrapChunk op' $ \isEmpty -> return $ YieldC n lbsC $ + -- Checking for empty case avoids allocating 'n-1' empty + -- buffers for 'n' insertChunksH right after each other. + if isEmpty + then fill nextStep fpbuf + else fillNew nextStep bufSize + + -- Yield a chunk, trimming it if necesary + {-# INLINE wrapChunk #-} + wrapChunk !op' mkCIOS + | pe < op' = error $ + "buildStepToCIOS: overwrite by " ++ show (op' `minusPtr` pe) ++ " bytes" + | chunkSize == 0 = mkCIOS True + | trim chunkSize size = do + bs <- S.create chunkSize $ \pbuf -> copyBytes pbuf op chunkSize + return $ Yield1 bs (mkCIOS False) + | otherwise = + return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False) + where + chunkSize = op' `minusPtr` op diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim.hs @@ -0,0 +1,776 @@ +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{- | Copyright : (c) 2010-2011 Simon Meier + (c) 2010 Jasper van der Jeugt +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +This module provides 'Builder' /primitives/, which are lower level building +blocks for constructing 'Builder's. You don't need to go down to this level but +it can be slightly faster. + +Morally, builder primitives are like functions @a -> Builder@, that is they +take a value and encode it as a sequence of bytes, represented as a 'Builder'. +Of course their implementation is a bit more specialised. + +Builder primitives come in two forms: fixed-size and bounded-size. + +* /Fixed(-size) primitives/ are builder primitives that always result in a + sequence of bytes of a fixed length. That is, the length is independent of + the value that is encoded. An example of a fixed size primitive is the + big-endian encoding of a 'Word64', which always results in exactly 8 bytes. + +* /Bounded(-size) primitives/ are builder primitives that always result in a + sequence of bytes that is no larger than a predetermined bound. That is, the + bound is independent of the value that is encoded but the actual length will + depend on the value. An example for a bounded primitive is the UTF-8 encoding + of a 'Char', which can be 1,2,3 or 4 bytes long, so the bound is 4 bytes. + +Note that fixed primitives can be considered as a special case of bounded +primitives, and we can lift from fixed to bounded. + +Because bounded primitives are the more general case, in this documentation we +only refer to fixed size primitives where it matters that the resulting +sequence of bytes is of a fixed length. Otherwise, we just refer to bounded +size primitives. + +The purpose of using builder primitives is to improve the performance of +'Builder's. These improvements stem from making the two most common steps +performed by a 'Builder' more efficient. We explain these two steps in turn. + +The first most common step is the concatenation of two 'Builder's. Internally, +concatenation corresponds to function composition. (Note that 'Builder's can +be seen as difference-lists of buffer-filling functions; cf. +. ) +Function composition is a fast /O(1)/ operation. However, we can use bounded +primitives to remove some of these function compositions altogether, which is +more efficient. + +The second most common step performed by a 'Builder' is to fill a buffer using +a bounded primitives, which works as follows. The 'Builder' checks whether +there is enough space left to execute the bounded primitive. If there is, then +the 'Builder' executes the bounded primitive and calls the next 'Builder' with +the updated buffer. Otherwise, the 'Builder' signals its driver that it +requires a new buffer. This buffer must be at least as large as the bound of +the primitive. We can use bounded primitives to reduce the number of +buffer-free checks by fusing the buffer-free checks of consecutive 'Builder's. +We can also use bounded primitives to simplify the control flow for signalling +that a buffer is full by ensuring that we check first that there is enough +space left and only then decide on how to encode a given value. + +Let us illustrate these improvements on the CSV-table rendering example from +"Data.ByteString.Builder". Its \"hot code\" is the rendering of a table's +cells, which we implement as follows using only the functions from the +'Builder' API. + +@ +import "Data.ByteString.Builder" as B + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = B.intDec i + +renderString :: String -> Builder +renderString cs = B.charUtf8 \'\"\' \<\> foldMap escape cs \<\> B.charUtf8 \'\"\' + where + escape \'\\\\\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\\\' + escape \'\\\"\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\"\' + escape c = B.charUtf8 c +@ + +Efficient encoding of 'Int's as decimal numbers is performed by @intDec@. +Optimization potential exists for the escaping of 'String's. The above +implementation has two optimization opportunities. First, the buffer-free +checks of the 'Builder's for escaping double quotes and backslashes can be +fused. Second, the concatenations performed by 'foldMap' can be eliminated. +The following implementation exploits these optimizations. + +@ +import qualified Data.ByteString.Builder.Prim as P +import Data.ByteString.Builder.Prim + ( 'condB', 'liftFixedToBounded', ('>*<'), ('>$<') ) + +renderString :: String -\> Builder +renderString cs = + B.charUtf8 \'\"\' \<\> E.'encodeListWithB' escape cs \<\> B.charUtf8 \'\"\' + where + escape :: E.'BoundedPrim' Char + escape = + 'condB' (== \'\\\\\') (fixed2 (\'\\\\\', \'\\\\\')) $ + 'condB' (== \'\\\"\') (fixed2 (\'\\\\\', \'\\\"\')) $ + E.'charUtf8' +   + {-\# INLINE fixed2 \#-} + fixed2 x = 'liftFixedToBounded' $ const x '>$<' E.'char7' '>*<' E.'char7' +@ + +The code should be mostly self-explanatory. The slightly awkward syntax is +because the combinators are written such that the size-bound of the resulting +'BoundedPrim' can be computed at compile time. We also explicitly inline the +'fixed2' primitive, which encodes a fixed tuple of characters, to ensure that +the bound computation happens at compile time. When encoding the following list +of 'String's, the optimized implementation of 'renderString' is two times +faster. + +@ +maxiStrings :: [String] +maxiStrings = take 1000 $ cycle [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] +@ + +Most of the performance gain stems from using 'primMapListBounded', which +encodes a list of values from left-to-right with a 'BoundedPrim'. It exploits +the 'Builder' internals to avoid unnecessary function compositions (i.e., +concatenations). In the future, we might expect the compiler to perform the +optimizations implemented in 'primMapListBounded'. However, it seems that the +code is currently to complicated for the compiler to see through. Therefore, we +provide the 'BoundedPrim' escape hatch, which allows data structures to provide +very efficient encoding traversals, like 'primMapListBounded' for lists. + +Note that 'BoundedPrim's are a bit verbose, but quite versatile. Here is an +example of a 'BoundedPrim' for combined HTML escaping and UTF-8 encoding. It +exploits that the escaped character with the maximal Unicode codepoint is \'>\'. + +@ +{-\# INLINE charUtf8HtmlEscaped \#-} +charUtf8HtmlEscaped :: E.BoundedPrim Char +charUtf8HtmlEscaped = + 'condB' (> \'\>\' ) E.'charUtf8' $ + 'condB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $ -- < + 'condB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $ -- > + 'condB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $ -- & + 'condB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $ -- &\#34; + 'condB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $ -- &\#39; + ('liftFixedToBounded' E.'char7') -- fallback for 'Char's smaller than \'\>\' + where + {-\# INLINE fixed4 \#-} + fixed4 x = 'liftFixedToBounded' $ const x '>$<' + E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 +   + {-\# INLINE fixed5 \#-} + fixed5 x = 'liftFixedToBounded' $ const x '>$<' + E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 +@ + +This module currently does not expose functions that require the special +properties of fixed-size primitives. They are useful for prefixing 'Builder's +with their size or for implementing chunked encodings. We will expose the +corresponding functions in future releases of this library. +-} + + + +{- +-- +-- +-- A /bounded primitive/ is a builder primitive that never results in a sequence +-- longer than some fixed number of bytes. This number of bytes must be +-- independent of the value being encoded. Typical examples of bounded +-- primitives are the big-endian encoding of a 'Word64', which results always +-- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always +-- in less or equal to 4 bytes. +-- +-- Typically, primitives are implemented efficiently by allocating a buffer (an +-- array of bytes) and repeatedly executing the following two steps: (1) +-- writing to the buffer until it is full and (2) handing over the filled part +-- to the consumer of the encoded value. Step (1) is where bounded primitives +-- are used. We must use a bounded primitive, as we must check that there is +-- enough free space /before/ actually writing to the buffer. +-- +-- In term of expressiveness, it would be sufficient to construct all encodings +-- from the single bounded encoding that encodes a 'Word8' as-is. However, +-- this is not sufficient in terms of efficiency. It results in unnecessary +-- buffer-full checks and it complicates the program-flow for writing to the +-- buffer, as buffer-full checks are interleaved with analysing the value to be +-- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a +-- significant effect on overall encoding performance, as encoding primitive +-- Haskell values such as 'Word8's or 'Char's lies at the heart of every +-- encoding implementation. +-- +-- The bounded 'Encoding's provided by this module remove this performance +-- problem. Intuitively, they consist of a tuple of the bound on the maximal +-- number of bytes written and the actual implementation of the encoding as a +-- function that modifies a mutable buffer. Hence when executing a bounded +-- 'Encoding', the buffer-full check can be done once before the actual writing +-- to the buffer. The provided 'Encoding's also take care to implement the +-- actual writing to the buffer efficiently. Moreover, combinators are +-- provided to construct new bounded encodings from the provided ones. +-- +-- A typical example for using the combinators is a bounded 'Encoding' that +-- combines escaping the ' and \\ characters with UTF-8 encoding. More +-- precisely, the escaping to be done is the one implemented by the following +-- @escape@ function. +-- +-- > escape :: Char -> [Char] +-- > escape '\'' = "\\'" +-- > escape '\\' = "\\\\" +-- > escape c = [c] +-- +-- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is +-- the following. +-- +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > {-# INLINE escapeChar #-} +-- > escapeUtf8 :: BoundedPrim Char +-- > escapeUtf8 = +-- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ +-- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ +-- > char +-- +-- The definition of 'escapeUtf8' is more complicated than 'escape', because +-- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in +-- 'escapeChar' compute both the bound on the maximal number of bytes written +-- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required +-- to implement the encoding. Bounded 'Encoding's should always be inlined. +-- Otherwise, the compiler cannot compute the bound on the maximal number of +-- bytes written at compile-time. Without inlinining, it would also fail to +-- optimize the constant encoding of the escape characters in the above +-- example. Functions that execute bounded 'Encoding's also perform +-- suboptimally, if the definition of the bounded 'Encoding' is not inlined. +-- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. +-- +-- Currently, the only library that executes bounded 'Encoding's is the +-- 'bytestring' library (). It +-- uses bounded 'Encoding's to implement most of its lazy bytestring builders. +-- Executing a bounded encoding should be done using the corresponding +-- functions in the lazy bytestring builder 'Extras' module. +-- +-- TODO: Merge with explanation/example below +-- +-- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by +-- writing a bounded-size sequence of bytes directly to memory. They are +-- lifted to conversions from Haskell values to 'Builder's by wrapping them +-- with a bound-check. The compiler can implement this bound-check very +-- efficiently (i.e, a single comparison of the difference of two pointers to a +-- constant), because the bound of a 'E.Encoding' is always independent of the +-- value being encoded and, in most cases, a literal constant. +-- +-- 'E.Encoding's are the primary means for defining conversion functions from +-- primitive Haskell values to 'Builder's. Most 'Builder' constructors +-- provided by this library are implemented that way. +-- 'E.Encoding's are also used to construct conversions that exploit the internal +-- representation of data-structures. +-- +-- For example, 'encodeByteStringWith' works directly on the underlying byte +-- array and uses some tricks to reduce the number of variables in its inner +-- loop. Its efficiency is exploited for implementing the @filter@ and @map@ +-- functions in "Data.ByteString.Lazy" as +-- +-- > import qualified Codec.Bounded.Encoding as E +-- > +-- > filter :: (Word8 -> Bool) -> ByteString -> ByteString +-- > filter p = toLazyByteString . encodeLazyByteStringWithB write +-- > where +-- > write = E.encodeIf p E.word8 E.emptyEncoding +-- > +-- > map :: (Word8 -> Word8) -> ByteString -> ByteString +-- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) +-- +-- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, +-- these versions use a more efficient inner loop and have the additional +-- advantage that they always result in well-chunked 'L.ByteString's; i.e, they +-- also perform automatic defragmentation. +-- +-- We can also use 'E.Encoding's to improve the efficiency of the following +-- 'renderString' function from our UTF-8 CSV table encoding example in +-- "Data.ByteString.Builder". +-- +-- > renderString :: String -> Builder +-- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' +-- > where +-- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' +-- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' +-- > escape c = charUtf8 c +-- +-- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes +-- characters and using 'encodeListWith', which implements writing a list of +-- values with a tighter inner loop and no 'mappend'. +-- +-- > import Data.ByteString.Builder.Extra -- assume these +-- > import Data.ByteString.Builder.Prim -- imports are present +-- > ( BoundedPrim, encodeIf, (<#>), (#.) ) +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > renderString :: String -> Builder +-- > renderString cs = +-- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' +-- > where +-- > escapedUtf8 :: BoundedPrim Char +-- > escapedUtf8 = +-- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ +-- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ +-- > char +-- +-- This 'Builder' considers a buffer with less than 8 free bytes as full. As +-- all functions are inlined, the compiler is able to optimize the constant +-- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of +-- 'renderString' this implementation is 1.7x faster. +-- +-} +{- +Internally, 'Builder's are buffer-fill operations that are +given a continuation buffer-fill operation and a buffer-range to be filled. +A 'Builder' first checks if the buffer-range is large enough. If that's +the case, the 'Builder' writes the sequences of bytes to the buffer and +calls its continuation. Otherwise, it returns a signal that it requires a +new buffer together with a continuation to be called on this new buffer. +Ignoring the rare case of a full buffer-range, the execution cost of a +'Builder' consists of three parts: + + 1. The time taken to read the parameters; i.e., the buffer-fill + operation to call after the 'Builder' is done and the buffer-range to + fill. + + 2. The time taken to check for the size of the buffer-range. + + 3. The time taken for the actual encoding. + +We can reduce cost (1) by ensuring that fewer buffer-fill function calls are +required. We can reduce cost (2) by fusing buffer-size checks of sequential +writes. For example, when escaping a 'String' using 'renderString', it would +be sufficient to check before encoding a character that at least 8 bytes are +free. We can reduce cost (3) by implementing better primitive 'Builder's. +For example, 'renderCell' builds an intermediate list containing the decimal +representation of an 'Int'. Implementing a direct decimal encoding of 'Int's +to memory would be more efficient, as it requires fewer buffer-size checks +and less allocation. It is also a planned extension of this library. + +The first two cost reductions are supported for user code through functions +in "Data.ByteString.Builder.Extra". There, we continue the above example +and drop the generation time to 0.8ms by implementing 'renderString' more +cleverly. The third reduction requires meddling with the internals of +'Builder's and is not recommended in code outside of this library. However, +patches to this library are very welcome. +-} +module Data.ByteString.Builder.Prim ( + + -- * Bounded-size primitives + + BoundedPrim + + -- ** Combinators + -- | The combinators for 'BoundedPrim's are implemented such that the + -- size of the resulting 'BoundedPrim' can be computed at compile time. + , emptyB + , (>*<) + , (>$<) + , eitherB + , condB + + -- ** Builder construction + , primBounded + , primMapListBounded + , primUnfoldrBounded + + , primMapByteStringBounded + , primMapLazyByteStringBounded + + -- * Fixed-size primitives + , FixedPrim + + -- ** Combinators + -- | The combinators for 'FixedPrim's are implemented such that the 'size' + -- of the resulting 'FixedPrim' is computed at compile time. + -- + -- The '(>*<)' and '(>$<)' pairing and mapping operators can be used + -- with 'FixedPrim'. + , emptyF + , liftFixedToBounded + + -- ** Builder construction + -- | In terms of expressivity, the function 'fixedPrim' would be sufficient + -- for constructing 'Builder's from 'FixedPrim's. The fused variants of + -- this function are provided because they allow for more efficient + -- implementations. Our compilers are just not smart enough yet; and for some + -- of the employed optimizations (see the code of 'encodeByteStringWithF') + -- they will very likely never be. + -- + -- Note that functions marked with \"/Heavy inlining./\" are forced to be + -- inlined because they must be specialized for concrete encodings, + -- but are rather heavy in terms of code size. We recommend to define a + -- top-level function for every concrete instantiation of such a function in + -- order to share its code. A typical example is the function + -- 'byteStringHex' from "Data.ByteString.Builder.ASCII", which is + -- implemented as follows. + -- + -- @ + -- byteStringHex :: S.ByteString -> Builder + -- byteStringHex = 'encodeByteStringWithF' 'word8HexFixed' + -- @ + -- + , primFixed + , primMapListFixed + , primUnfoldrFixed + + , primMapByteStringFixed + , primMapLazyByteStringFixed + + -- * Standard encodings of Haskell values + + , module Data.ByteString.Builder.Prim.Binary + + -- ** Character encodings + , module Data.ByteString.Builder.Prim.ASCII + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode + -- codepoint to 8-bits and encoding them as a single byte. For the codepoints + -- 0-255 this corresponds to the ISO/IEC 8859-1 encoding. Note that the + -- Char8 encoding is equivalent to the ASCII encoding on the Unicode + -- codepoints 0-127. Hence, functions such as 'intDec' can also be used for + -- encoding 'Int's as a decimal number with Char8 encoded characters. + , char8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode all Unicode codepoints. + -- It is equivalent to the ASCII encoding on the Unicode codepoints 0-127. + -- Hence, functions such as 'intDec' can also be used for encoding 'Int's as + -- a decimal number with UTF-8 encoded characters. + , charUtf8 + +{- + -- * Testing support + -- | The following four functions are intended for testing use + -- only. They are /not/ efficient. Basic encodings are efficently executed by + -- creating 'Builder's from them using the @encodeXXX@ functions explained at + -- the top of this module. + + , evalF + , evalB + + , showF + , showB +-} + ) where + +import Data.ByteString.Builder.Internal +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts +import Data.ByteString.Builder.Prim.Internal.Base16 (lowerTable, encode4_as_8) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +import Data.Monoid +import Data.List (unfoldr) -- HADDOCK ONLY +import Data.Char (chr, ord) +import Control.Monad ((<=<), unless) + +import Data.ByteString.Builder.Prim.Internal hiding (size, sizeBound) +import qualified Data.ByteString.Builder.Prim.Internal as I (size, sizeBound) +import Data.ByteString.Builder.Prim.Binary +import Data.ByteString.Builder.Prim.ASCII + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + +------------------------------------------------------------------------------ +-- Creating Builders from bounded primitives +------------------------------------------------------------------------------ + +-- | Encode a value with a 'FixedPrim'. +{-# INLINE primFixed #-} +primFixed :: FixedPrim a -> (a -> Builder) +primFixed = primBounded . toB + +-- | Encode a list of values from left-to-right with a 'FixedPrim'. +{-# INLINE primMapListFixed #-} +primMapListFixed :: FixedPrim a -> ([a] -> Builder) +primMapListFixed = primMapListBounded . toB + +-- | Encode a list of values represented as an 'unfoldr' with a 'FixedPrim'. +{-# INLINE primUnfoldrFixed #-} +primUnfoldrFixed :: FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder +primUnfoldrFixed = primUnfoldrBounded . toB + +-- | /Heavy inlining./ Encode all bytes of a strict 'S.ByteString' from +-- left-to-right with a 'FixedPrim'. This function is quite versatile. For +-- example, we can use it to construct a 'Builder' that maps every byte before +-- copying it to the buffer to be filled. +-- +-- > mapToBuilder :: (Word8 -> Word8) -> S.ByteString -> Builder +-- > mapToBuilder f = encodeByteStringWithF (contramapF f word8) +-- +-- We can also use it to hex-encode a strict 'S.ByteString' as shown by the +-- 'byteStringHex' example above. +{-# INLINE primMapByteStringFixed #-} +primMapByteStringFixed :: FixedPrim Word8 -> (S.ByteString -> Builder) +primMapByteStringFixed = primMapByteStringBounded . toB + +-- | /Heavy inlining./ Encode all bytes of a lazy 'L.ByteString' from +-- left-to-right with a 'FixedPrim'. +{-# INLINE primMapLazyByteStringFixed #-} +primMapLazyByteStringFixed :: FixedPrim Word8 -> (L.ByteString -> Builder) +primMapLazyByteStringFixed = primMapLazyByteStringBounded . toB + +-- IMPLEMENTATION NOTE: Sadly, 'encodeListWith' cannot be used for foldr/build +-- fusion. Its performance relies on hoisting several variables out of the +-- inner loop. That's not possible when writing 'encodeListWith' as a 'foldr'. +-- If we had stream fusion for lists, then we could fuse 'encodeListWith', as +-- 'encodeWithStream' can keep control over the execution. + + +-- | Create a 'Builder' that encodes values with the given 'BoundedPrim'. +-- +-- We rewrite consecutive uses of 'primBounded' such that the bound-checks are +-- fused. For example, +-- +-- > primBounded (word32 c1) `mappend` primBounded (word32 c2) +-- +-- is rewritten such that the resulting 'Builder' checks only once, if ther are +-- at 8 free bytes, instead of checking twice, if there are 4 free bytes. This +-- optimization is not observationally equivalent in a strict sense, as it +-- influences the boundaries of the generated chunks. However, for a user of +-- this library it is observationally equivalent, as chunk boundaries of a lazy +-- 'L.ByteString' can only be observed through the internal interface. +-- Morevoer, we expect that all primitives write much fewer than 4kb (the +-- default short buffer size). Hence, it is safe to ignore the additional +-- memory spilled due to the more agressive buffer wrapping introduced by this +-- optimization. +-- +{-# INLINE[1] primBounded #-} +primBounded :: BoundedPrim a -> (a -> Builder) +primBounded w = + mkBuilder + where + bound = I.sizeBound w + mkBuilder x = builder step + where + step k (BufferRange op ope) + | op `plusPtr` bound <= ope = do + op' <- runB w x op + let !br' = BufferRange op' ope + k br' + | otherwise = return $ bufferFull bound op (step k) + +{-# RULES + +"append/primBounded" forall w1 w2 x1 x2. + append (primBounded w1 x1) (primBounded w2 x2) + = primBounded (pairB w1 w2) (x1, x2) + +"append/primBounded/assoc_r" forall w1 w2 x1 x2 b. + append (primBounded w1 x1) (append (primBounded w2 x2) b) + = append (primBounded (pairB w1 w2) (x1, x2)) b + +"append/primBounded/assoc_l" forall w1 w2 x1 x2 b. + append (append b (primBounded w1 x1)) (primBounded w2 x2) + = append b (primBounded (pairB w1 w2) (x1, x2)) + #-} + +-- TODO: The same rules for 'putBuilder (..) >> putBuilder (..)' + +-- | Create a 'Builder' that encodes a list of values consecutively using a +-- 'BoundedPrim' for each element. This function is more efficient than the +-- canonical +-- +-- > filter p = +-- > B.toLazyByteString . +-- > E.encodeLazyByteStringWithF (E.ifF p E.word8) E.emptyF) +-- > +-- +-- > mconcat . map (primBounded w) +-- +-- or +-- +-- > foldMap (primBounded w) +-- +-- because it moves several variables out of the inner loop. +{-# INLINE primMapListBounded #-} +primMapListBounded :: BoundedPrim a -> [a] -> Builder +primMapListBounded w = + makeBuilder + where + bound = I.sizeBound w + makeBuilder xs0 = builder $ step xs0 + where + step xs1 k !(BufferRange op0 ope0) = go xs1 op0 + where + go [] !op = do + let !br' = BufferRange op ope0 + k br' + + go xs@(x':xs') !op + | op `plusPtr` bound <= ope0 = do + !op' <- runB w x' op + go xs' op' + | otherwise = return $ bufferFull bound op (step xs k) + +-- TODO: Add 'foldMap/encodeWith' its variants +-- TODO: Ensure rewriting 'primBounded w . f = primBounded (w #. f)' + +-- | Create a 'Builder' that encodes a sequence generated from a seed value +-- using a 'BoundedPrim' for each sequence element. +{-# INLINE primUnfoldrBounded #-} +primUnfoldrBounded :: BoundedPrim b -> (a -> Maybe (b, a)) -> a -> Builder +primUnfoldrBounded w = + makeBuilder + where + bound = I.sizeBound w + makeBuilder f x0 = builder $ step x0 + where + step x1 !k = fill x1 + where + fill x !(BufferRange pf0 pe0) = go (f x) pf0 + where + go !Nothing !pf = do + let !br' = BufferRange pf pe0 + k br' + go !(Just (y, x')) !pf + | pf `plusPtr` bound <= pe0 = do + !pf' <- runB w y pf + go (f x') pf' + | otherwise = return $ bufferFull bound pf $ + \(BufferRange pfNew peNew) -> do + !pfNew' <- runB w y pfNew + fill x' (BufferRange pfNew' peNew) + +-- | Create a 'Builder' that encodes each 'Word8' of a strict 'S.ByteString' +-- using a 'BoundedPrim'. For example, we can write a 'Builder' that filters +-- a strict 'S.ByteString' as follows. +-- +-- > import Data.ByteString.Builder.Primas P (word8, condB, emptyB) +-- +-- > filterBS p = P.condB p P.word8 P.emptyB +-- +{-# INLINE primMapByteStringBounded #-} +primMapByteStringBounded :: BoundedPrim Word8 -> S.ByteString -> Builder +primMapByteStringBounded w = + \bs -> builder $ step bs + where + bound = I.sizeBound w + step (S.PS ifp ioff isize) !k = + goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) + where + !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) + goBS !ip0 !br@(BufferRange op0 ope) + | ip0 >= ipe = do + touchForeignPtr ifp -- input buffer consumed + k br + + | op0 `plusPtr` bound < ope = + goPartial (ip0 `plusPtr` min outRemaining inpRemaining) + + | otherwise = return $ bufferFull bound op0 (goBS ip0) + where + outRemaining = (ope `minusPtr` op0) `div` bound + inpRemaining = ipe `minusPtr` ip0 + + goPartial !ipeTmp = go ip0 op0 + where + go !ip !op + | ip < ipeTmp = do + x <- peek ip + op' <- runB w x op + go (ip `plusPtr` 1) op' + | otherwise = + goBS ip (BufferRange op ope) + +-- | Chunk-wise application of 'primMapByteStringBounded'. +{-# INLINE primMapLazyByteStringBounded #-} +primMapLazyByteStringBounded :: BoundedPrim Word8 -> L.ByteString -> Builder +primMapLazyByteStringBounded w = + L.foldrChunks (\x b -> primMapByteStringBounded w x `mappend` b) mempty + + +------------------------------------------------------------------------------ +-- Char8 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: FixedPrim Char +char8 = (fromIntegral . ord) >$< word8 + + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: BoundedPrim Char +charUtf8 = boundedEncoding 4 (encodeCharUtf8 f1 f2 f3 f4) + where + pokeN n io op = io op >> return (op `plusPtr` n) + + f1 x1 = pokeN 1 $ \op -> do pokeByteOff op 0 x1 + + f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + + f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + + f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + pokeByteOff op 3 x4 + +-- | Encode a Unicode character to another datatype, using UTF-8. This function +-- acts as an abstract way of encoding characters, as it is unaware of what +-- needs to happen with the resulting bytes: you have to specify functions to +-- deal with those. +-- +{-# INLINE encodeCharUtf8 #-} +encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 + -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 + -> Char -- ^ Input 'Char' + -> a -- ^ Result +encodeCharUtf8 f1 f2 f3 f4 c = case ord c of + x | x <= 0x7F -> f1 $ fromIntegral x + | x <= 0x07FF -> + let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f2 x1 x2 + | x <= 0xFFFF -> + let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f3 x1 x2 x3 + | otherwise -> + let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f4 x1 x2 x3 x4 + + +------------------------------------------------------------------------------ +-- Testing encodings +------------------------------------------------------------------------------ +{- +-- | /For testing use only./ Evaluate a 'FixedPrim' on a given value. +evalF :: FixedPrim a -> a -> [Word8] +evalF fe = S.unpack . S.unsafeCreate (I.size fe) . runF fe + +-- | /For testing use only./ Evaluate a 'BoundedPrim' on a given value. +evalB :: BoundedPrim a -> a -> [Word8] +evalB be x = S.unpack $ unsafePerformIO $ + S.createAndTrim (I.sizeBound be) $ \op -> do + op' <- runB be x op + return (op' `minusPtr` op) + +-- | /For testing use only./ Show the result of a 'FixedPrim' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showF :: FixedPrim a -> a -> String +showF fe = map (chr . fromIntegral) . evalF fe + +-- | /For testing use only./ Show the result of a 'BoundedPrim' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showB :: BoundedPrim a -> a -> String +showB be = map (chr . fromIntegral) . evalB be +-} + diff --git a/Data/ByteString/Builder/Prim/ASCII.hs b/Data/ByteString/Builder/Prim/ASCII.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/ASCII.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Encodings using ASCII encoded Unicode characters. +-- +module Data.ByteString.Builder.Prim.ASCII + ( + + -- *** ASCII + char7 + + -- **** Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + , int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + {- + -- These are the functions currently provided by Bryan O'Sullivans + -- double-conversion library. + -- + -- , float + -- , floatWith + -- , double + -- , doubleWith + -} + + -- **** Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest possible representation is used. For + -- example, + -- + -- > toLazyByteString (primBounded word16Hex 0x0a10) = "a10" + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- **** Fixed-width hexadecimal numbers + -- + -- | Encoding the bytes of fixed-width types as hexadecimal + -- numbers using lower-case ASCII characters. For example, + -- + -- > toLazyByteString (primFixed word16HexFixed 0x0a10) = "0a10" + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + , floatHexFixed + , doubleHexFixed + + ) where + +import Data.ByteString.Builder.Prim.Binary +import Data.ByteString.Builder.Prim.Internal +import Data.ByteString.Builder.Prim.Internal.Floating +import Data.ByteString.Builder.Prim.Internal.Base16 +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts + +import Data.Char (ord) + +import Foreign +import Foreign.C.Types + +-- | Encode the least 7-bits of a 'Char' using the ASCII encoding. +{-# INLINE char7 #-} +char7 :: FixedPrim Char +char7 = (\c -> fromIntegral $ ord c .&. 0x7f) >$< word8 + + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec + :: CInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec + :: CLLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeIntDecimal #-} +encodeIntDecimal :: Integral a => Int -> BoundedPrim a +encodeIntDecimal bound = boundedEncoding bound $ c_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int8'. +{-# INLINE int8Dec #-} +int8Dec :: BoundedPrim Int8 +int8Dec = encodeIntDecimal 4 + +-- | Decimal encoding of an 'Int16'. +{-# INLINE int16Dec #-} +int16Dec :: BoundedPrim Int16 +int16Dec = encodeIntDecimal 6 + + +-- | Decimal encoding of an 'Int32'. +{-# INLINE int32Dec #-} +int32Dec :: BoundedPrim Int32 +int32Dec = encodeIntDecimal 11 + +-- | Decimal encoding of an 'Int64'. +{-# INLINE int64Dec #-} +int64Dec :: BoundedPrim Int64 +int64Dec = boundedEncoding 20 $ c_long_long_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int'. +{-# INLINE intDec #-} +intDec :: BoundedPrim Int +intDec = caseWordSize_32_64 + (fromIntegral >$< int32Dec) + (fromIntegral >$< int64Dec) + + +-- Unsigned integers +-------------------- + +foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeWordDecimal #-} +encodeWordDecimal :: Integral a => Int -> BoundedPrim a +encodeWordDecimal bound = boundedEncoding bound $ c_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word8'. +{-# INLINE word8Dec #-} +word8Dec :: BoundedPrim Word8 +word8Dec = encodeWordDecimal 3 + +-- | Decimal encoding of a 'Word16'. +{-# INLINE word16Dec #-} +word16Dec :: BoundedPrim Word16 +word16Dec = encodeWordDecimal 5 + +-- | Decimal encoding of a 'Word32'. +{-# INLINE word32Dec #-} +word32Dec :: BoundedPrim Word32 +word32Dec = encodeWordDecimal 10 + +-- | Decimal encoding of a 'Word64'. +{-# INLINE word64Dec #-} +word64Dec :: BoundedPrim Word64 +word64Dec = boundedEncoding 20 $ c_long_long_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word'. +{-# INLINE wordDec #-} +wordDec :: BoundedPrim Word +wordDec = caseWordSize_32_64 + (fromIntegral >$< word32Dec) + (fromIntegral >$< word64Dec) + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeWordHex #-} +encodeWordHex :: forall a. (Storable a, Integral a) => BoundedPrim a +encodeWordHex = + boundedEncoding (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word8'. +{-# INLINE word8Hex #-} +word8Hex :: BoundedPrim Word8 +word8Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word16'. +{-# INLINE word16Hex #-} +word16Hex :: BoundedPrim Word16 +word16Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word32'. +{-# INLINE word32Hex #-} +word32Hex :: BoundedPrim Word32 +word32Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word64'. +{-# INLINE word64Hex #-} +word64Hex :: BoundedPrim Word64 +word64Hex = boundedEncoding 16 $ c_long_long_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word'. +{-# INLINE wordHex #-} +wordHex :: BoundedPrim Word +wordHex = caseWordSize_32_64 + (fromIntegral >$< word32Hex) + (fromIntegral >$< word64Hex) + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: FixedPrim Word8 +word8HexFixed = fixedEncoding 2 $ + \x op -> poke (castPtr op) =<< encode8_as_16h lowerTable x + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: FixedPrim Word16 +word16HexFixed = + (\x -> (fromIntegral $ x `shiftr_w16` 8, fromIntegral x)) + >$< pairF word8HexFixed word8HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: FixedPrim Word32 +word32HexFixed = + (\x -> (fromIntegral $ x `shiftr_w32` 16, fromIntegral x)) + >$< pairF word16HexFixed word16HexFixed +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: FixedPrim Word64 +word64HexFixed = + (\x -> (fromIntegral $ x `shiftr_w64` 32, fromIntegral x)) + >$< pairF word32HexFixed word32HexFixed + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: FixedPrim Int8 +int8HexFixed = fromIntegral >$< word8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: FixedPrim Int16 +int16HexFixed = fromIntegral >$< word16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: FixedPrim Int32 +int32HexFixed = fromIntegral >$< word32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: FixedPrim Int64 +int64HexFixed = fromIntegral >$< word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: FixedPrim Float +floatHexFixed = encodeFloatViaWord32F word32HexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: FixedPrim Double +doubleHexFixed = encodeDoubleViaWord64F word64HexFixed + + diff --git a/Data/ByteString/Builder/Prim/Binary.hs b/Data/ByteString/Builder/Prim/Binary.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Binary.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE CPP, BangPatterns #-} +-- | Copyright : (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +module Data.ByteString.Builder.Prim.Binary ( + + -- ** Binary encodings + int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- *** Non-portable, host-dependent + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + +import Data.ByteString.Builder.Prim.Internal +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts +import Data.ByteString.Builder.Prim.Internal.Floating + +import Foreign + +#include "MachDeps.h" + +------------------------------------------------------------------------------ +-- Binary encoding +------------------------------------------------------------------------------ + +-- Word encodings +----------------- + +-- | Encoding single unsigned bytes as-is. +-- +{-# INLINE word8 #-} +word8 :: FixedPrim Word8 +word8 = storableToF + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Encoding 'Word16's in big endian format. +{-# INLINE word16BE #-} +word16BE :: FixedPrim Word16 +#ifdef WORD_BIGENDIAN +word16BE = word16Host +#else +word16BE = fixedEncoding 2 $ \w p -> do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +#endif + +-- | Encoding 'Word16's in little endian format. +{-# INLINE word16LE #-} +word16LE :: FixedPrim Word16 +#ifdef WORD_BIGENDIAN +word16LE = fixedEncoding 2 $ \w p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +#else +word16LE = word16Host +#endif + +-- | Encoding 'Word32's in big endian format. +{-# INLINE word32BE #-} +word32BE :: FixedPrim Word32 +#ifdef WORD_BIGENDIAN +word32BE = word32Host +#else +word32BE = fixedEncoding 4 $ \w p -> do + poke p (fromIntegral (shiftr_w32 w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) +#endif + +-- | Encoding 'Word32's in little endian format. +{-# INLINE word32LE #-} +word32LE :: FixedPrim Word32 +#ifdef WORD_BIGENDIAN +word32LE = fixedEncoding 4 $ \w p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) +#else +word32LE = word32Host +#endif + +-- on a little endian machine: +-- word32LE w32 = fixedEncoding 4 (\w p -> poke (castPtr p) w32) + +-- | Encoding 'Word64's in big endian format. +{-# INLINE word64BE #-} +word64BE :: FixedPrim Word64 +#ifdef WORD_BIGENDIAN +word64BE = word64Host +#else +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +word64BE = + fixedEncoding 8 $ \w p -> do + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + poke p (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) +#else +word64BE = fixedEncoding 8 $ \w p -> do + poke p (fromIntegral (shiftr_w64 w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) +#endif +#endif + +-- | Encoding 'Word64's in little endian format. +{-# INLINE word64LE #-} +word64LE :: FixedPrim Word64 +#ifdef WORD_BIGENDIAN +#if WORD_SIZE_IN_BITS < 64 +word64LE = + fixedEncoding 8 $ \w p -> do + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + poke (p) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) +#else +word64LE = fixedEncoding 8 $ \w p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) +#endif +#else +word64LE = word64Host +#endif + + +-- | Encode a single native machine 'Word'. The 'Word's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: FixedPrim Word +wordHost = storableToF + +-- | Encoding 'Word16's in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: FixedPrim Word16 +word16Host = storableToF + +-- | Encoding 'Word32's in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: FixedPrim Word32 +word32Host = storableToF + +-- | Encoding 'Word64's in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: FixedPrim Word64 +word64Host = storableToF + + +------------------------------------------------------------------------------ +-- Int encodings +------------------------------------------------------------------------------ +-- +-- We rely on 'fromIntegral' to do a loss-less conversion to the corresponding +-- 'Word' type +-- +------------------------------------------------------------------------------ + +-- | Encoding single signed bytes as-is. +-- +{-# INLINE int8 #-} +int8 :: FixedPrim Int8 +int8 = fromIntegral >$< word8 + +-- | Encoding 'Int16's in big endian format. +{-# INLINE int16BE #-} +int16BE :: FixedPrim Int16 +int16BE = fromIntegral >$< word16BE + +-- | Encoding 'Int16's in little endian format. +{-# INLINE int16LE #-} +int16LE :: FixedPrim Int16 +int16LE = fromIntegral >$< word16LE + +-- | Encoding 'Int32's in big endian format. +{-# INLINE int32BE #-} +int32BE :: FixedPrim Int32 +int32BE = fromIntegral >$< word32BE + +-- | Encoding 'Int32's in little endian format. +{-# INLINE int32LE #-} +int32LE :: FixedPrim Int32 +int32LE = fromIntegral >$< word32LE + +-- | Encoding 'Int64's in big endian format. +{-# INLINE int64BE #-} +int64BE :: FixedPrim Int64 +int64BE = fromIntegral >$< word64BE + +-- | Encoding 'Int64's in little endian format. +{-# INLINE int64LE #-} +int64LE :: FixedPrim Int64 +int64LE = fromIntegral >$< word64LE + + +-- TODO: Ensure that they are safe on architectures where an unaligned write is +-- an error. + +-- | Encode a single native machine 'Int'. The 'Int's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or integer sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: FixedPrim Int +intHost = storableToF + +-- | Encoding 'Int16's in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: FixedPrim Int16 +int16Host = storableToF + +-- | Encoding 'Int32's in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: FixedPrim Int32 +int32Host = storableToF + +-- | Encoding 'Int64's in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: FixedPrim Int64 +int64Host = storableToF + +-- IEEE Floating Point Numbers +------------------------------ + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: FixedPrim Float +floatBE = encodeFloatViaWord32F word32BE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: FixedPrim Float +floatLE = encodeFloatViaWord32F word32LE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: FixedPrim Double +doubleBE = encodeDoubleViaWord64F word64BE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: FixedPrim Double +doubleLE = encodeDoubleViaWord64F word64LE + + +-- | Encode a 'Float' in native host order and host endianness. Values written +-- this way are not portable to different endian machines, without conversion. +-- +{-# INLINE floatHost #-} +floatHost :: FixedPrim Float +floatHost = storableToF + +-- | Encode a 'Double' in native host order and host endianness. +{-# INLINE doubleHost #-} +doubleHost :: FixedPrim Double +doubleHost = storableToF + + diff --git a/Data/ByteString/Builder/Prim/Extra.hs b/Data/ByteString/Builder/Prim/Extra.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Extra.hs @@ -0,0 +1,890 @@ +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK hide #-} +{- | Copyright : (c) 2010-2011 Simon Meier +License : BSD3-style (see LICENSE) + +Maintainer : Simon Meier +Stability : experimental +Portability : GHC + +An /encoding/ is a conversion function of Haskell values to sequences of bytes. +A /fixed(-size) encoding/ is an encoding that always results in sequence of bytes + of a pre-determined, fixed length. +An example for a fixed encoding is the big-endian encoding of a 'Word64', + which always results in exactly 8 bytes. +A /bounded(-size) encoding/ is an encoding that always results in sequence + of bytes that is no larger than a pre-determined bound. +An example for a bounded encoding is the UTF-8 encoding of a 'Char', + which results always in less or equal to 4 bytes. +Note that every fixed encoding is also a bounded encoding. +We explicitly identify fixed encodings because they allow some optimizations + that are impossible with bounded encodings. +In the following, + we first motivate the use of bounded encodings + and then give examples of optimizations + that are only possible with fixed encodings. + +Typicall, encodings are implemented efficiently by allocating a buffer + (a mutable array of bytes) + and repeatedly executing the following two steps: + (1) writing to the buffer until it is full and + (2) handing over the filled part to the consumer of the encoded value. +Step (1) is where bounded encodings are used. +We must use a bounded encoding, + as we must check that there is enough free space + /before/ actually writing to the buffer. + +In term of expressivity, + it would be sufficient to construct all encodings + from the single fixed encoding that encodes a 'Word8' as-is. +However, + this is not sufficient in terms of efficiency. +It results in unnecessary buffer-full checks and + it complicates the program-flow for writing to the buffer, + as buffer-full checks are interleaved with analyzing the value to be + encoded (e.g., think about the program-flow for UTF-8 encoding). +This has a significant effect on overall encoding performance, + as encoding primitive Haskell values such as 'Word8's or 'Char's + lies at the heart of every encoding implementation. + +The 'BoundedPrim's provided by this module remove this performance problem. +Intuitively, + they consist of a tuple of the bound on the maximal number of bytes written + and the actual implementation of the encoding as + a function that modifies a mutable buffer. +Hence when executing a 'BoundedPrim', + the buffer-full check can be done once before the actual writing to the buffer. +The provided 'BoundedPrim's also take care to implement the + actual writing to the buffer efficiently. +Moreover, combinators are provided to construct new bounded encodings + from the provided ones. + + + +The result of an encoding can be consumed efficiently, + if it is represented as a sequence of large enough + /chunks/ of consecutive memory (i.e., C @char@ arrays). +The precise meaning of /large enough/ is application dependent. +Typically, an average chunk size between 4kb and 32kb is suitable + for writing the result to disk or sending it over the network. +We desire large enough chunk sizes because each chunk boundary + incurs extra work that we must be able to amortize. + + +The need for fixed-size encodings arises when considering + the efficient implementation of encodings that require the encoding of a + value to be prefixed with the size of the resulting sequence of bytes. +An efficient implementation avoids unnecessary buffer +We can implement this efficiently as follows. +We first reserve the space for the encoding of the size. +Then, we encode the value. +Finally, we encode the size of the resulting sequence of bytes into + the reserved space. +For this to work + +This works only if the encoding resulting size fits + +by first, reserving the space for the encoding + of the size, then performing the + +For efficiency, + we want to avoid unnecessary copying. + + +For example, the HTTP/1.0 requires the size of the body to be given in + the Content-Length field. + +chunked-transfer encoding requires each chunk to + be prefixed with the hexadecimal encoding of the chunk size. + + +-} + +{- +-- +-- +-- A /bounded encoding/ is an encoding that never results in a sequence +-- longer than some fixed number of bytes. This number of bytes must be +-- independent of the value being encoded. Typical examples of bounded +-- encodings are the big-endian encoding of a 'Word64', which results always +-- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always +-- in less or equal to 4 bytes. +-- +-- Typically, encodings are implemented efficiently by allocating a buffer (an +-- array of bytes) and repeatedly executing the following two steps: (1) +-- writing to the buffer until it is full and (2) handing over the filled part +-- to the consumer of the encoded value. Step (1) is where bounded encodings +-- are used. We must use a bounded encoding, as we must check that there is +-- enough free space /before/ actually writing to the buffer. +-- +-- In term of expressivity, it would be sufficient to construct all encodings +-- from the single bounded encoding that encodes a 'Word8' as-is. However, +-- this is not sufficient in terms of efficiency. It results in unnecessary +-- buffer-full checks and it complicates the program-flow for writing to the +-- buffer, as buffer-full checks are interleaved with analyzing the value to be +-- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a +-- significant effect on overall encoding performance, as encoding primitive +-- Haskell values such as 'Word8's or 'Char's lies at the heart of every +-- encoding implementation. +-- +-- The bounded 'Encoding's provided by this module remove this performance +-- problem. Intuitively, they consist of a tuple of the bound on the maximal +-- number of bytes written and the actual implementation of the encoding as a +-- function that modifies a mutable buffer. Hence when executing a bounded +-- 'Encoding', the buffer-full check can be done once before the actual writing +-- to the buffer. The provided 'Encoding's also take care to implement the +-- actual writing to the buffer efficiently. Moreover, combinators are +-- provided to construct new bounded encodings from the provided ones. +-- +-- A typical example for using the combinators is a bounded 'Encoding' that +-- combines escaping the ' and \\ characters with UTF-8 encoding. More +-- precisely, the escaping to be done is the one implemented by the following +-- @escape@ function. +-- +-- > escape :: Char -> [Char] +-- > escape '\'' = "\\'" +-- > escape '\\' = "\\\\" +-- > escape c = [c] +-- +-- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is +-- the following. +-- +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > {-# INLINE escapeChar #-} +-- > escapeUtf8 :: BoundedPrim Char +-- > escapeUtf8 = +-- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ +-- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ +-- > char +-- +-- The definition of 'escapeUtf8' is more complicated than 'escape', because +-- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in +-- 'escapeChar' compute both the bound on the maximal number of bytes written +-- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required +-- to implement the encoding. Bounded 'Encoding's should always be inlined. +-- Otherwise, the compiler cannot compute the bound on the maximal number of +-- bytes written at compile-time. Without inlinining, it would also fail to +-- optimize the constant encoding of the escape characters in the above +-- example. Functions that execute bounded 'Encoding's also perform +-- suboptimally, if the definition of the bounded 'Encoding' is not inlined. +-- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. +-- +-- Currently, the only library that executes bounded 'Encoding's is the +-- 'bytestring' library (). It +-- uses bounded 'Encoding's to implement most of its lazy bytestring builders. +-- Executing a bounded encoding should be done using the corresponding +-- functions in the lazy bytestring builder 'Extras' module. +-- +-- TODO: Merge with explanation/example below +-- +-- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by +-- writing a bounded-size sequence of bytes directly to memory. They are +-- lifted to conversions from Haskell values to 'Builder's by wrapping them +-- with a bound-check. The compiler can implement this bound-check very +-- efficiently (i.e, a single comparison of the difference of two pointers to a +-- constant), because the bound of a 'E.Encoding' is always independent of the +-- value being encoded and, in most cases, a literal constant. +-- +-- 'E.Encoding's are the primary means for defining conversion functions from +-- primitive Haskell values to 'Builder's. Most 'Builder' constructors +-- provided by this library are implemented that way. +-- 'E.Encoding's are also used to construct conversions that exploit the internal +-- representation of data-structures. +-- +-- For example, 'encodeByteStringWith' works directly on the underlying byte +-- array and uses some tricks to reduce the number of variables in its inner +-- loop. Its efficiency is exploited for implementing the @filter@ and @map@ +-- functions in "Data.ByteString.Lazy" as +-- +-- > import qualified Data.ByteString.Builder.Prim as P +-- > +-- > filter :: (Word8 -> Bool) -> ByteString -> ByteString +-- > filter p = toLazyByteString . encodeLazyByteStringWithB write +-- > where +-- > write = P.condB p P.word8 P.emptyB +-- > +-- > map :: (Word8 -> Word8) -> ByteString -> ByteString +-- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) +-- +-- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, +-- these versions use a more efficient inner loop and have the additional +-- advantage that they always result in well-chunked 'L.ByteString's; i.e, they +-- also perform automatic defragmentation. +-- +-- We can also use 'E.Encoding's to improve the efficiency of the following +-- 'renderString' function from our UTF-8 CSV table encoding example in +-- "Data.ByteString.Builder". +-- +-- > renderString :: String -> Builder +-- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' +-- > where +-- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' +-- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' +-- > escape c = charUtf8 c +-- +-- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes +-- characters and using 'encodeListWith', which implements writing a list of +-- values with a tighter inner loop and no 'mappend'. +-- +-- > import Data.ByteString.Builder.Extra -- assume these +-- > import Data.ByteString.Builder.Prim -- imports are present +-- > ( BoundedPrim, encodeIf, (<#>), (#.) ) +-- > import Data.ByteString.Builder.Prim.Utf8 (char) +-- > +-- > renderString :: String -> Builder +-- > renderString cs = +-- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' +-- > where +-- > escapedUtf8 :: BoundedPrim Char +-- > escapedUtf8 = +-- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ +-- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ +-- > char +-- +-- This 'Builder' considers a buffer with less than 8 free bytes as full. As +-- all functions are inlined, the compiler is able to optimize the constant +-- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of +-- 'renderString' this implementation is 1.7x faster. +-- +-} +{- +Internally, 'Builder's are buffer-fill operations that are +given a continuation buffer-fill operation and a buffer-range to be filled. +A 'Builder' first checks if the buffer-range is large enough. If that's +the case, the 'Builder' writes the sequences of bytes to the buffer and +calls its continuation. Otherwise, it returns a signal that it requires a +new buffer together with a continuation to be called on this new buffer. +Ignoring the rare case of a full buffer-range, the execution cost of a +'Builder' consists of three parts: + + 1. The time taken to read the parameters; i.e., the buffer-fill + operation to call after the 'Builder' is done and the buffer-range to + fill. + + 2. The time taken to check for the size of the buffer-range. + + 3. The time taken for the actual encoding. + +We can reduce cost (1) by ensuring that fewer buffer-fill function calls are +required. We can reduce cost (2) by fusing buffer-size checks of sequential +writes. For example, when escaping a 'String' using 'renderString', it would +be sufficient to check before encoding a character that at least 8 bytes are +free. We can reduce cost (3) by implementing better primitive 'Builder's. +For example, 'renderCell' builds an intermediate list containing the decimal +representation of an 'Int'. Implementing a direct decimal encoding of 'Int's +to memory would be more efficient, as it requires fewer buffer-size checks +and less allocation. It is also a planned extension of this library. + +The first two cost reductions are supported for user code through functions +in "Data.ByteString.Builder.Extra". There, we continue the above example +and drop the generation time to 0.8ms by implementing 'renderString' more +cleverly. The third reduction requires meddling with the internals of +'Builder's and is not recomended in code outside of this library. However, +patches to this library are very welcome. +-} +module Data.ByteString.Builder.Prim.Extra ( + + -- * Base-128, variable-length binary encodings + {- | +There are many options for implementing a base-128 (i.e, 7-bit), +variable-length encoding. The encoding implemented here is the one used by +Google's protocol buffer library +. This +encoding can be implemented efficiently and provides the desired property that +small positive integers result in short sequences of bytes. It is intended to +be used for the new default binary serialization format of the differently +sized 'Word' types. It works as follows. + +The most-significant bit (MSB) of each output byte indicates whether +there is a following byte (MSB set to 1) or it is the last byte (MSB set to 0). +The remaining 7-bits are used to encode the input starting with the least +significant 7-bit group of the input (i.e., a little-endian ordering of the +7-bit groups is used). + +For example, the value @1 :: Int@ is encoded as @[0x01]@. The value +@128 :: Int@, whose binary representation is @1000 0000@, is encoded as +@[0x80, 0x01]@; i.e., the first byte has its MSB set and the least significant +7-bit group is @000 0000@, the second byte has its MSB not set (it is the last +byte) and its 7-bit group is @000 0001@. +-} + word8Var + , word16Var + , word32Var + , word64Var + , wordVar + +{- | +The following encodings work by casting the signed integer to the equally sized +unsigned integer. This works well for positive integers, but for negative +integers it always results in the longest possible sequence of bytes, +as their MSB is (by definition) always set. +-} + + , int8Var + , int16Var + , int32Var + , int64Var + , intVar + +{- | +Positive and negative integers of small magnitude can be encoded compactly + using the so-called ZigZag encoding + (). +The /ZigZag encoding/ uses + even numbers to encode the postive integers and + odd numbers to encode the negative integers. +For example, + @0@ is encoded as @0@, @-1@ as @1@, @1@ as @2@, @-2@ as @3@, @2@ as @4@, and + so on. +Its efficient implementation uses some bit-level magic. +For example + +@ +zigZag32 :: 'Int32' -> 'Word32' +zigZag32 n = fromIntegral ((n \`shiftL\` 1) \`xor\` (n \`shiftR\` 31)) +@ + +Note that the 'shiftR' is an arithmetic shift that performs sign extension. +The ZigZag encoding essentially swaps the LSB with the MSB and additionally +inverts all bits if the MSB is set. + +The following encodings implement the combintion of ZigZag encoding + together with the above base-128, variable length encodings. +They are intended to become the the new default binary serialization format of + the differently sized 'Int' types. +-} + , int8VarSigned + , int16VarSigned + , int32VarSigned + , int64VarSigned + , intVarSigned + + + -- * Chunked / size-prefixed encodings +{- | +Some encodings like ASN.1 BER +or Google's protocol buffers require +encoded data to be prefixed with its length. The simple method to achieve this +is to encode the data first into a separate buffer, compute the length of the +encoded data, write it to the current output buffer, and append the separate +buffers. The drawback of this method is that it requires a ... +-} + , size + , sizeBound + -- , withSizeFB + -- , withSizeBB + , encodeWithSize + + , encodeChunked + + , wordVarFixedBound + , wordHexFixedBound + , wordDecFixedBound + + , word64VarFixedBound + , word64HexFixedBound + , word64DecFixedBound + + ) where + +import Data.ByteString.Builder.Internal +import Data.ByteString.Builder.Prim.Internal.UncheckedShifts +import Data.ByteString.Builder.Prim.Internal.Base16 (lowerTable, encode4_as_8) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +import Data.Monoid +import Data.List (unfoldr) -- HADDOCK ONLY +import Data.Char (chr, ord) +import Control.Monad ((<=<), unless) + +import Data.ByteString.Builder.Prim.Internal hiding (size, sizeBound) +import qualified Data.ByteString.Builder.Prim.Internal as I (size, sizeBound) +import Data.ByteString.Builder.Prim.Binary +import Data.ByteString.Builder.Prim.ASCII +import Data.ByteString.Builder.Prim + +import Foreign + +------------------------------------------------------------------------------ +-- Adapting 'size' for the public interface. +------------------------------------------------------------------------------ + +-- | The size of the sequence of bytes generated by this 'FixedPrim'. +size :: FixedPrim a -> Word +size = fromIntegral . I.size + +-- | The bound on the size of the sequence of bytes generated by this +-- 'BoundedPrim'. +sizeBound :: BoundedPrim a -> Word +sizeBound = fromIntegral . I.sizeBound + + +------------------------------------------------------------------------------ +-- Base-128 Variable-Length Encodings +------------------------------------------------------------------------------ + +{-# INLINE encodeBase128 #-} +encodeBase128 + :: forall a b. (Integral a, Bits a, Storable b, Integral b, Num b) + => (a -> Int -> a) -> BoundedPrim b +encodeBase128 shiftr = + -- We add 6 because we require the result of (`div` 7) to be rounded up. + boundedEncoding ((8 * sizeOf (undefined :: b) + 6) `div` 7) (io . fromIntegral) + where + io !x !op + | x' == 0 = do poke8 (x .&. 0x7f) + return $! op `plusPtr` 1 + | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) + io x' (op `plusPtr` 1) + where + x' = x `shiftr` 7 + poke8 = poke op . fromIntegral + +-- | Base-128, variable length encoding of a 'Word8'. +{-# INLINE word8Var #-} +word8Var :: BoundedPrim Word8 +word8Var = encodeBase128 shiftr_w + +-- | Base-128, variable length encoding of a 'Word16'. +{-# INLINE word16Var #-} +word16Var :: BoundedPrim Word16 +word16Var = encodeBase128 shiftr_w + +-- | Base-128, variable length encoding of a 'Word32'. +{-# INLINE word32Var #-} +word32Var :: BoundedPrim Word32 +word32Var = encodeBase128 shiftr_w32 + +-- | Base-128, variable length encoding of a 'Word64'. +{-# INLINE word64Var #-} +word64Var :: BoundedPrim Word64 +word64Var = encodeBase128 shiftr_w64 + +-- | Base-128, variable length encoding of a 'Word'. +{-# INLINE wordVar #-} +wordVar :: BoundedPrim Word +wordVar = encodeBase128 shiftr_w + + +-- | Base-128, variable length encoding of an 'Int8'. +-- Use 'int8VarSigned' for encoding negative numbers. +{-# INLINE int8Var #-} +int8Var :: BoundedPrim Int8 +int8Var = fromIntegral >$< word8Var + +-- | Base-128, variable length encoding of an 'Int16'. +-- Use 'int16VarSigned' for encoding negative numbers. +{-# INLINE int16Var #-} +int16Var :: BoundedPrim Int16 +int16Var = fromIntegral >$< word16Var + +-- | Base-128, variable length encoding of an 'Int32'. +-- Use 'int32VarSigned' for encoding negative numbers. +{-# INLINE int32Var #-} +int32Var :: BoundedPrim Int32 +int32Var = fromIntegral >$< word32Var + +-- | Base-128, variable length encoding of an 'Int64'. +-- Use 'int64VarSigned' for encoding negative numbers. +{-# INLINE int64Var #-} +int64Var :: BoundedPrim Int64 +int64Var = fromIntegral >$< word64Var + +-- | Base-128, variable length encoding of an 'Int'. +-- Use 'intVarSigned' for encoding negative numbers. +{-# INLINE intVar #-} +intVar :: BoundedPrim Int +intVar = fromIntegral >$< wordVar + +{-# INLINE zigZag #-} +zigZag :: (Storable a, Bits a) => a -> a +zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1)) + +-- | Base-128, variable length, ZigZag encoding of an 'Int'. +{-# INLINE int8VarSigned #-} +int8VarSigned :: BoundedPrim Int8 +int8VarSigned = zigZag >$< int8Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int16'. +{-# INLINE int16VarSigned #-} +int16VarSigned :: BoundedPrim Int16 +int16VarSigned = zigZag >$< int16Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int32'. +{-# INLINE int32VarSigned #-} +int32VarSigned :: BoundedPrim Int32 +int32VarSigned = zigZag >$< int32Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int64'. +{-# INLINE int64VarSigned #-} +int64VarSigned :: BoundedPrim Int64 +int64VarSigned = zigZag >$< int64Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int'. +{-# INLINE intVarSigned #-} +intVarSigned :: BoundedPrim Int +intVarSigned = zigZag >$< intVar + + + +------------------------------------------------------------------------------ +-- Chunked Encoding Transformer +------------------------------------------------------------------------------ + +-- | /Heavy inlining./ +{-# INLINE encodeChunked #-} +encodeChunked + :: Word -- ^ Minimal free-size + -> (Word64 -> FixedPrim Word64) + -- ^ Given a sizeBound on the maximal encodable size this function must return + -- a fixed-size encoding for encoding all smaller size. + -> (BoundedPrim Word64) + -- ^ An encoding for terminating a chunk of the given size. + -> Builder + -- ^ Inner Builder to transform + -> Builder + -- ^ 'Put' with chunked encoding. +encodeChunked minFree mkBeforeFE afterBE = + fromPut . putChunked minFree mkBeforeFE afterBE . putBuilder + +-- | /Heavy inlining./ +{-# INLINE putChunked #-} +putChunked + :: Word -- ^ Minimal free-size + -> (Word64 -> FixedPrim Word64) + -- ^ Given a sizeBound on the maximal encodable size this function must return + -- a fixed-size encoding for encoding all smaller size. + -> (BoundedPrim Word64) + -- ^ Encoding a directly inserted chunk. + -> Put a + -- ^ Inner Put to transform + -> Put a + -- ^ 'Put' with chunked encoding. +putChunked minFree0 mkBeforeFE afterBE p = + put encodingStep + where + minFree, reservedAfter, maxReserved, minBufferSize :: Int + minFree = fromIntegral $ max 1 minFree0 -- sanitize and convert to Int + + -- reserved space must be computed for maximum buffer size to cover for all + -- sizes of the actually returned buffer. + reservedAfter = I.sizeBound afterBE + maxReserved = I.size (mkBeforeFE maxBound) + reservedAfter + minBufferSize = minFree + maxReserved + + encodingStep k = + fill (runPut p) + where + fill innerStep !(BufferRange op ope) + | outRemaining < minBufferSize = + return $! bufferFull minBufferSize op (fill innerStep) + | otherwise = do + fillWithBuildStep innerStep doneH fullH insertChunksH brInner + where + outRemaining = ope `minusPtr` op + beforeFE = mkBeforeFE $ fromIntegral outRemaining + reservedBefore = I.size beforeFE + + opInner = op `plusPtr` reservedBefore + opeInner = ope `plusPtr` (-reservedAfter) + brInner = BufferRange opInner opeInner + + wrapChunk :: Ptr Word8 -> IO (Ptr Word8) + wrapChunk !opInner' + | innerSize == 0 = return op -- no data written => no chunk to wrap + | otherwise = do + runF beforeFE innerSize op + runB afterBE innerSize opInner' + where + innerSize = fromIntegral $ opInner' `minusPtr` opInner + + doneH opInner' x = do + op' <- wrapChunk opInner' + let !br' = BufferRange op' ope + k x br' + + fullH opInner' minSize nextInnerStep = do + op' <- wrapChunk opInner' + return $! bufferFull + (max minBufferSize (minSize + maxReserved)) + op' + (fill nextInnerStep) + + insertChunksH opInner' n lbsC nextInnerStep + | n == 0 = do -- flush + op' <- wrapChunk opInner' + return $! insertChunks op' 0 id (fill nextInnerStep) + + | otherwise = do -- insert non-empty bytestring + op' <- wrapChunk opInner' + let !br' = BufferRange op' ope + runBuilderWith chunkB (fill nextInnerStep) br' + where + nU = fromIntegral n + chunkB = + primFixed (mkBeforeFE nU) nU `mappend` + lazyByteStringC n lbsC `mappend` + primBounded afterBE nU + + +-- | /Heavy inlining./ Prefix a 'Builder' with the size of the +-- sequence of bytes that it denotes. +-- +-- This function is optimized for streaming use. It tries to prefix the size +-- without copying the output. This is achieved by reserving space for the +-- maximum size to be encoded. This succeeds if the output is smaller than +-- the current free buffer size, which is guaranteed to be at least @8kb@. +-- +-- If the output does not fit into the current free buffer size, +-- the method falls back to encoding the data to a separate lazy bytestring, +-- computing the size, and encoding the size before inserting the chunks of +-- the separate lazy bytestring. +{-# INLINE encodeWithSize #-} +encodeWithSize + :: + Word + -- ^ Inner buffer-size. + -> (Word64 -> FixedPrim Word64) + -- ^ Given a bound on the maximal size to encode, this function must return + -- a fixed-size encoding for all smaller sizes. + -> Builder + -- ^ 'Put' to prefix with the length of its sequence of bytes. + -> Builder +encodeWithSize innerBufSize mkSizeFE = + fromPut . putWithSize innerBufSize mkSizeFE . putBuilder + +-- | Prefix a 'Put' with the size of its written data. +{-# INLINE putWithSize #-} +putWithSize + :: forall a. + Word + -- ^ Buffer-size for inner driver. + -> (Word64 -> FixedPrim Word64) + -- ^ Encoding the size for the fallback case. + -> Put a + -- ^ 'Put' to prefix with the length of its sequence of bytes. + -> Put a +putWithSize innerBufSize mkSizeFE innerP = + put $ encodingStep + where + -- | The minimal free size is such that we can encode any size. + minFree = I.size $ mkSizeFE maxBound + + encodingStep :: (forall r. (a -> BuildStep r) -> BuildStep r) + encodingStep k = + fill (runPut innerP) + where + fill :: BuildStep a -> BufferRange -> IO (BuildSignal r) + fill innerStep !(BufferRange op ope) + | outRemaining < minFree = + return $! bufferFull minFree op (fill innerStep) + | otherwise = do + fillWithBuildStep innerStep doneH fullH insertChunksH brInner + where + outRemaining = ope `minusPtr` op + sizeFE = mkSizeFE $ fromIntegral outRemaining + reservedBefore = I.size sizeFE + reservedAfter = minFree - reservedBefore + + -- leave enough free space such that all sizes can be encodded. + startInner = op `plusPtr` reservedBefore + opeInner = ope `plusPtr` (negate reservedAfter) + brInner = BufferRange startInner opeInner + + fastPrefixSize :: Ptr Word8 -> IO (Ptr Word8) + fastPrefixSize !opInner' + | innerSize == 0 = do runB (toB $ mkSizeFE 0) 0 op + | otherwise = do runF (sizeFE) innerSize op + return opInner' + where + innerSize = fromIntegral $ opInner' `minusPtr` startInner + + slowPrefixSize :: Ptr Word8 -> Builder -> BuildStep a -> IO (BuildSignal r) + slowPrefixSize opInner' bInner nextStep = do + (x, chunks, payLenChunks) <- toLBS $ runBuilderWith bInner nextStep + + let -- length of payload data in current buffer + payLenCur = opInner' `minusPtr` startInner + -- length of whole payload + payLen = fromIntegral payLenCur + fromIntegral payLenChunks + -- encoder for payload length + sizeFE' = mkSizeFE payLen + -- start of payload in current buffer with the payload + -- length encoded before + startInner' = op `plusPtr` I.size sizeFE' + + -- move data in current buffer out of the way, if required + unless (startInner == startInner') $ + moveBytes startInner' startInner payLenCur + -- encode payload length at start of the buffer + runF sizeFE' payLen op + -- TODO: If we were to change the CIOS definition such that it also + -- returns the last buffer for writing, we could also fill the + -- last buffer with 'k' and return the signal, once it is + -- filled, therefore avoiding unfilled space. + return $ insertChunks (startInner' `plusPtr` payLenCur) + payLenChunks + chunks + (k x) + where + toLBS = runCIOSWithLength <=< + buildStepToCIOSUntrimmedWith (fromIntegral innerBufSize) + + doneH :: Ptr Word8 -> a -> IO (BuildSignal r) + doneH opInner' x = do + op' <- fastPrefixSize opInner' + let !br' = BufferRange op' ope + k x br' + + fullH :: Ptr Word8 -> Int -> BuildStep a -> IO (BuildSignal r) + fullH opInner' minSize nextInnerStep = + slowPrefixSize opInner' (ensureFree minSize) nextInnerStep + + insertChunksH :: Ptr Word8 -> Int64 -> LazyByteStringC + -> BuildStep a -> IO (BuildSignal r) + insertChunksH opInner' n lbsC nextInnerStep = + slowPrefixSize opInner' (lazyByteStringC n lbsC) nextInnerStep + + +-- | Run a 'ChunkIOStream' and gather its results and their length. +runCIOSWithLength :: ChunkIOStream a -> IO (a, LazyByteStringC, Int64) +runCIOSWithLength = + go 0 id + where + go !l lbsC (Finished x) = return (x, lbsC, l) + go !l lbsC (YieldC n lbsC' io) = io >>= go (l + n) (lbsC . lbsC') + go !l lbsC (Yield1 bs io) = + io >>= go (l + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) + +-- | Run a 'BuildStep' using the untrimmed strategy. +buildStepToCIOSUntrimmedWith :: Int -> BuildStep a -> IO (ChunkIOStream a) +buildStepToCIOSUntrimmedWith bufSize = + buildStepToCIOS (untrimmedStrategy bufSize bufSize) + (return . Finished) + + +---------------------------------------------------------------------- +-- Padded versions of encodings for streamed prefixing of output sizes +---------------------------------------------------------------------- + +{-# INLINE appsUntilZero #-} +appsUntilZero :: (Eq a, Num a) => (a -> a) -> a -> Int +appsUntilZero f x0 = + count 0 x0 + where + count !n 0 = n + count !n x = count (succ n) (f x) + + +{-# INLINE genericVarFixedBound #-} +genericVarFixedBound :: (Eq b, Show b, Bits b, Num a, Integral b) + => (b -> a -> b) -> b -> FixedPrim b +genericVarFixedBound shiftRight bound = + fixedEncoding n0 io + where + n0 = max 1 $ appsUntilZero (`shiftRight` 7) bound + + io !x0 !op + | x0 > bound = error err + | otherwise = loop 0 x0 + where + err = "genericVarFixedBound: value " ++ show x0 ++ " > bound " ++ show bound + loop !n !x + | n0 <= n + 1 = do poke8 (x .&. 0x7f) + | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) + loop (n + 1) (x `shiftRight` 7) + where + poke8 = pokeElemOff op n . fromIntegral + +{-# INLINE wordVarFixedBound #-} +wordVarFixedBound :: Word -> FixedPrim Word +wordVarFixedBound = genericVarFixedBound shiftr_w + +{-# INLINE word64VarFixedBound #-} +word64VarFixedBound :: Word64 -> FixedPrim Word64 +word64VarFixedBound = genericVarFixedBound shiftr_w64 + + +-- Somehow this function doesn't really make sense, as the bound must be +-- greater when interpreted as an unsigned integer. These conversions and +-- decisions should be left to the user. +-- +--{-# INLINE intVarFixed #-} +--intVarFixed :: Size -> FixedPrim Size +--intVarFixed bound = fromIntegral >$< wordVarFixed (fromIntegral bound) + +{-# INLINE genHexFixedBound #-} +genHexFixedBound :: (Num a, Bits a, Integral a) + => (a -> Int -> a) -> Char -> a -> FixedPrim a +genHexFixedBound shiftr padding0 bound = + fixedEncoding n0 io + where + n0 = max 1 $ appsUntilZero (`shiftr` 4) bound + + padding = fromIntegral (ord padding0) :: Word8 + + io !x0 !op0 = + loop (op0 `plusPtr` n0) x0 + where + loop !op !x = do + let !op' = op `plusPtr` (-1) + poke op' =<< encode4_as_8 lowerTable (fromIntegral $ x .&. 0xf) + let !x' = x `shiftr` 4 + unless (op' <= op0) $ + if x' == 0 + then pad (op' `plusPtr` (-1)) + else loop op' x' + + pad !op + | op < op0 = return () + | otherwise = poke op padding >> pad (op `plusPtr` (-1)) + + +{-# INLINE wordHexFixedBound #-} +wordHexFixedBound :: Char -> Word -> FixedPrim Word +wordHexFixedBound = genHexFixedBound shiftr_w + +{-# INLINE word64HexFixedBound #-} +word64HexFixedBound :: Char -> Word64 -> FixedPrim Word64 +word64HexFixedBound = genHexFixedBound shiftr_w64 + +-- | Note: Works only for positive numbers. +{-# INLINE genDecFixedBound #-} +genDecFixedBound :: (Num a, Bits a, Integral a) + => Char -> a -> FixedPrim a +genDecFixedBound padding0 bound = + fixedEncoding n0 io + where + n0 = max 1 $ appsUntilZero (`div` 10) bound + + padding = fromIntegral (ord padding0) :: Word8 + + io !x0 !op0 = + loop (op0 `plusPtr` n0) x0 + where + loop !op !x = do + let !op' = op `plusPtr` (-1) + !x' = x `div` 10 + poke op' ((fromIntegral $ (x - x' * 10) + 48) :: Word8) + unless (op' <= op0) $ + if x' == 0 + then pad (op' `plusPtr` (-1)) + else loop op' x' + + pad !op + | op < op0 = return () + | otherwise = poke op padding >> pad (op `plusPtr` (-1)) + +{-# INLINE wordDecFixedBound #-} +wordDecFixedBound :: Char -> Word -> FixedPrim Word +wordDecFixedBound = genDecFixedBound + +{-# INLINE word64DecFixedBound #-} +word64DecFixedBound :: Char -> Word64 -> FixedPrim Word64 +word64DecFixedBound = genDecFixedBound + diff --git a/Data/ByteString/Builder/Prim/Internal.hs b/Data/ByteString/Builder/Prim/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Internal.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : unstable, private +-- Portability : GHC +-- +-- *Warning:* this module is internal. If you find that you need it please +-- contact the maintainers and explain what you are trying to do and discuss +-- what you would need in the public API. It is important that you do this as +-- the module may not be exposed at all in future releases. +-- +-- The maintainers are glad to accept patches for further +-- standard encodings of standard Haskell values. +-- +-- If you need to write your own builder primitives, then be aware that you are +-- writing code with /all saftey belts off/; i.e., +-- *this is the code that might make your application vulnerable to buffer-overflow attacks!* +-- The "Data.ByteString.Builder.Prim.Tests" module provides you with +-- utilities for testing your encodings thoroughly. +-- +module Data.ByteString.Builder.Prim.Internal ( + -- * Fixed-size builder primitives + Size + , FixedPrim + , fixedEncoding + , size + , runF + + , emptyF + , contramapF + , pairF + -- , liftIOF + + , storableToF + + -- * Bounded-size builder primitives + , BoundedPrim + , boundedEncoding + , sizeBound + , runB + + , emptyB + , contramapB + , pairB + , eitherB + , condB + + -- , liftIOB + + , toB + , liftFixedToBounded + + -- , withSizeFB + -- , withSizeBB + + -- * Shared operators + , (>$<) + , (>*<) + + ) where + +import Foreign +import Prelude hiding (maxBound) + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611 +-- ghc-6.10 and older do not support {-# INLINE CONLIKE #-} +#define CONLIKE +#endif + +------------------------------------------------------------------------------ +-- Supporting infrastructure +------------------------------------------------------------------------------ + +-- | Contravariant functors as in the @contravariant@ package. +class Contravariant f where + contramap :: (b -> a) -> f a -> f b + +infixl 4 >$< + +-- | A fmap-like operator for builder primitives, both bounded and fixed size. +-- +-- Builder primitives are contravariant so it's like the normal fmap, but +-- backwards (look at the type). (If it helps to remember, the operator symbol +-- is like (<$>) but backwards.) +-- +-- We can use it for example to prepend and/or append fixed values to an +-- primitive. +-- +-- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'" +-- > where +-- > fixed3 = char7 >*< char7 >*< char7 +-- +-- Note that the rather verbose syntax for composition stems from the +-- requirement to be able to compute the size / size bound at compile time. +-- +(>$<) :: Contravariant f => (b -> a) -> f a -> f b +(>$<) = contramap + + +instance Contravariant FixedPrim where + contramap = contramapF + +instance Contravariant BoundedPrim where + contramap = contramapB + + +-- | Type-constructors supporting lifting of type-products. +class Monoidal f where + pair :: f a -> f b -> f (a, b) + +instance Monoidal FixedPrim where + pair = pairF + +instance Monoidal BoundedPrim where + pair = pairB + +infixr 5 >*< + +-- | A pairing/concatenation operator for builder primitives, both bounded and +-- fixed size. +-- +-- For example, +-- +-- > toLazyByteString (primFixed (char7 >*< char7) ('x','y')) = "xy" +-- +-- We can combine multiple primitives using '>*<' multiple times. +-- +-- > toLazyByteString (primFixed (char7 >*< char7 >*< char7) ('x',('y','z'))) = "xyz" +-- +(>*<) :: Monoidal f => f a -> f b -> f (a, b) +(>*<) = pair + + +-- | The type used for sizes and sizeBounds of sizes. +type Size = Int + + +------------------------------------------------------------------------------ +-- Fixed-size builder primitives +------------------------------------------------------------------------------ + +-- | A builder primitive that always results in a sequence of bytes of a +-- pre-determined, fixed size. +data FixedPrim a = FE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ()) + +fixedEncoding :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a +fixedEncoding = FE + +-- | The size of the sequences of bytes generated by this 'FixedPrim'. +{-# INLINE CONLIKE size #-} +size :: FixedPrim a -> Int +size (FE l _) = l + +{-# INLINE CONLIKE runF #-} +runF :: FixedPrim a -> a -> Ptr Word8 -> IO () +runF (FE _ io) = io + +-- | The 'FixedPrim' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyF #-} +emptyF :: FixedPrim a +emptyF = FE 0 (\_ _ -> return ()) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairF #-} +pairF :: FixedPrim a -> FixedPrim b -> FixedPrim (a, b) +pairF (FE l1 io1) (FE l2 io2) = + FE (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1)) + +-- | Change a primitives such that it first applies a function to the value +-- to be encoded. +-- +-- Note that primitives are 'Contrafunctors' +-- . Hence, the following +-- laws hold. +-- +-- >contramapF id = id +-- >contramapF f . contramapF g = contramapF (g . f) +{-# INLINE CONLIKE contramapF #-} +contramapF :: (b -> a) -> FixedPrim a -> FixedPrim b +contramapF f (FE l io) = FE l (\x op -> io (f x) op) + +-- | Convert a 'FixedPrim' to a 'BoundedPrim'. +{-# INLINE CONLIKE toB #-} +toB :: FixedPrim a -> BoundedPrim a +toB (FE l io) = BE l (\x op -> io x op >> (return $! op `plusPtr` l)) + +-- | Lift a 'FixedPrim' to a 'BoundedPrim'. +{-# INLINE CONLIKE liftFixedToBounded #-} +liftFixedToBounded :: FixedPrim a -> BoundedPrim a +liftFixedToBounded = toB + +{-# INLINE CONLIKE storableToF #-} +storableToF :: forall a. Storable a => FixedPrim a +storableToF = FE (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) + +{- +{-# INLINE CONLIKE liftIOF #-} +liftIOF :: FixedPrim a -> FixedPrim (IO a) +liftIOF (FE l io) = FE l (\xWrapped op -> do x <- xWrapped; io x op) +-} + +------------------------------------------------------------------------------ +-- Bounded-size builder primitives +------------------------------------------------------------------------------ + +-- | A builder primitive that always results in sequence of bytes that is no longer +-- than a pre-determined bound. +data BoundedPrim a = BE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8)) + +-- | The bound on the size of sequences of bytes generated by this 'BoundedPrim'. +{-# INLINE CONLIKE sizeBound #-} +sizeBound :: BoundedPrim a -> Int +sizeBound (BE b _) = b + +boundedEncoding :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a +boundedEncoding = BE + +{-# INLINE CONLIKE runB #-} +runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8) +runB (BE _ io) = io + +-- | Change a 'BoundedPrim' such that it first applies a function to the +-- value to be encoded. +-- +-- Note that 'BoundedPrim's are 'Contrafunctors' +-- . Hence, the following +-- laws hold. +-- +-- >contramapB id = id +-- >contramapB f . contramapB g = contramapB (g . f) +{-# INLINE CONLIKE contramapB #-} +contramapB :: (b -> a) -> BoundedPrim a -> BoundedPrim b +contramapB f (BE b io) = BE b (\x op -> io (f x) op) + +-- | The 'BoundedPrim' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyB #-} +emptyB :: BoundedPrim a +emptyB = BE 0 (\_ op -> return op) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairB #-} +pairB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b) +pairB (BE b1 io1) (BE b2 io2) = + BE (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2) + +-- | Encode an 'Either' value using the first 'BoundedPrim' for 'Left' +-- values and the second 'BoundedPrim' for 'Right' values. +-- +-- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below +-- using '>$<') suffice to construct 'BoundedPrim's for all non-recursive +-- algebraic datatypes. For example, +-- +-- @ +--maybeB :: BoundedPrim () -> BoundedPrim a -> BoundedPrim (Maybe a) +--maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just +-- @ +{-# INLINE CONLIKE eitherB #-} +eitherB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b) +eitherB (BE b1 io1) (BE b2 io2) = + BE (max b1 b2) + (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op) + +-- | Conditionally select a 'BoundedPrim'. +-- For example, we can implement the ASCII primitive that drops characters with +-- Unicode codepoints above 127 as follows. +-- +-- @ +--charASCIIDrop = 'condB' (< '\128') ('fromF' 'char7') 'emptyB' +-- @ +{-# INLINE CONLIKE condB #-} +condB :: (a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a +condB p be1 be2 = + contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2) + + +{- +{-# INLINE withSizeFB #-} +withSizeFB :: (Word -> FixedPrim Word) -> BoundedPrim a -> BoundedPrim a +withSizeFB feSize (BE b io) = + BE (lSize + b) + (\x op0 -> do let !op1 = op0 `plusPtr` lSize + op2 <- io x op1 + ioSize (fromIntegral $ op2 `minusPtr` op1) op0 + return op2) + where + FE lSize ioSize = feSize (fromIntegral b) + + +{-# INLINE withSizeBB #-} +withSizeBB :: BoundedPrim Word -> BoundedPrim a -> BoundedPrim a +withSizeBB (BE bSize ioSize) (BE b io) = + BE (bSize + 2*b) + (\x op0 -> do let !opTmp = op0 `plusPtr` (bSize + b) + opTmp' <- io x opTmp + let !s = opTmp' `minusPtr` opTmp + op1 <- ioSize (fromIntegral s) op0 + copyBytes op1 opTmp s + return $! op1 `plusPtr` s) + +{-# INLINE CONLIKE liftIOB #-} +liftIOB :: BoundedPrim a -> BoundedPrim (IO a) +liftIOB (BE l io) = BE l (\xWrapped op -> do x <- xWrapped; io x op) +-} + +------------------------------------------------------------------------------ +-- Builder primitives from 'ByteString's. +------------------------------------------------------------------------------ + +{- +-- | A 'FixedPrim' that always results in the same byte sequence given as a +-- strict 'S.ByteString'. We can use this primitive to insert fixed ... +{-# INLINE CONLIKE constByteStringF #-} +constByteStringF :: S.ByteString -> FixedPrim () +constByteStringF bs = + FE len io + where + (S.PS fp off len) = bs + io _ op = do + copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) len + touchForeignPtr fp + +-- | Encode a fixed-length prefix of a strict 'S.ByteString' as-is. We can use +-- this function to +{-# INLINE byteStringPrefixB #-} +byteStringTakeB :: Int -- ^ Length of the prefix. It should be smaller than + -- 100 bytes, as otherwise + -> BoundedPrim S.ByteString +byteStringTakeB n0 = + BE n io + where + n = max 0 n0 -- sanitize + + io (S.PS fp off len) op = do + let !s = min len n + copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) s + touchForeignPtr fp + return $! op `plusPtr` s +-} + +{- + +httpChunkedTransfer :: Builder -> Builder +httpChunkedTransfer = + encodeChunked 32 (word64HexFixedBound '0') + ((\_ -> ('\r',('\n',('\r','\n')))) >$< char8x4) + where + char8x4 = toB (char8 >*< char8 >*< char8 >*< char8) + + + +chunked :: Builder -> Builder +chunked = encodeChunked 16 word64VarFixedBound emptyB + +-} + + + diff --git a/Data/ByteString/Builder/Prim/Internal/Base16.hs b/Data/ByteString/Builder/Prim/Internal/Base16.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Internal/Base16.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Hexadecimal encoding of nibbles (4-bit) and octets (8-bit) as ASCII +-- characters. +-- +-- The current implementation is based on a table based encoding inspired by +-- the code in the 'base64-bytestring' library by Bryan O'Sullivan. In our +-- benchmarks on a 32-bit machine it turned out to be the fastest +-- implementation option. +-- +module Data.ByteString.Builder.Prim.Internal.Base16 ( + EncodingTable + -- , upperTable + , lowerTable + , encode4_as_8 + , encode8_as_16h + -- , encode8_as_8_8 + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + +-- Creating the encoding tables +------------------------------- + +-- TODO: Use table from C implementation. + +-- | An encoding table for Base16 encoding. +newtype EncodingTable = EncodingTable (ForeignPtr Word8) + +tableFromList :: [Word8] -> EncodingTable +tableFromList xs = case S.pack xs of S.PS fp _ _ -> EncodingTable fp + +unsafeIndex :: EncodingTable -> Int -> IO Word8 +unsafeIndex (EncodingTable table) = peekElemOff (unsafeForeignPtrToPtr table) + +base16EncodingTable :: EncodingTable -> IO EncodingTable +base16EncodingTable alphabet = do + xs <- sequence $ concat $ [ [ix j, ix k] | j <- [0..15], k <- [0..15] ] + return $ tableFromList xs + where + ix = unsafeIndex alphabet + +{- +{-# NOINLINE upperAlphabet #-} +upperAlphabet :: EncodingTable +upperAlphabet = + tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['A'..'F'] + +-- | The encoding table for hexadecimal values with upper-case characters; +-- e.g., DEADBEEF. +{-# NOINLINE upperTable #-} +upperTable :: EncodingTable +upperTable = unsafePerformIO $ base16EncodingTable upperAlphabet +-} + +{-# NOINLINE lowerAlphabet #-} +lowerAlphabet :: EncodingTable +lowerAlphabet = + tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['a'..'f'] + +-- | The encoding table for hexadecimal values with lower-case characters; +-- e.g., deadbeef. +{-# NOINLINE lowerTable #-} +lowerTable :: EncodingTable +lowerTable = unsafePerformIO $ base16EncodingTable lowerAlphabet + + +-- Encoding nibbles and octets +------------------------------ + +-- | Encode a nibble as an octet. +-- +-- > encode4_as_8 lowerTable 10 = fromIntegral (char 'a') +-- +{-# INLINE encode4_as_8 #-} +encode4_as_8 :: EncodingTable -> Word8 -> IO Word8 +encode4_as_8 table x = unsafeIndex table (2 * fromIntegral x + 1) +-- TODO: Use a denser table to reduce cache utilization. + +-- | Encode an octet as 16bit word comprising both encoded nibbles ordered +-- according to the host endianness. Writing these 16bit to memory will write +-- the nibbles in the correct order (i.e. big-endian). +{-# INLINE encode8_as_16h #-} +encode8_as_16h :: EncodingTable -> Word8 -> IO Word16 +encode8_as_16h (EncodingTable table) = + peekElemOff (castPtr $ unsafeForeignPtrToPtr table) . fromIntegral + +{- +-- | Encode an octet as a big-endian ordered tuple of octets; i.e., +-- +-- > encode8_as_8_8 lowerTable 10 +-- > = (fromIntegral (chr '0'), fromIntegral (chr 'a')) +-- +{-# INLINE encode8_as_8_8 #-} +encode8_as_8_8 :: EncodingTable -> Word8 -> IO (Word8, Word8) +encode8_as_8_8 table x = + (,) <$> unsafeIndex table i <*> unsafeIndex table (i + 1) + where + i = 2 * fromIntegral x +-} diff --git a/Data/ByteString/Builder/Prim/Internal/Floating.hs b/Data/ByteString/Builder/Prim/Internal/Floating.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Internal/Floating.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Conversion of 'Float's and 'Double's to 'Word32's and 'Word64's. +-- +module Data.ByteString.Builder.Prim.Internal.Floating + ( + -- coerceFloatToWord32 + -- , coerceDoubleToWord64 + encodeFloatViaWord32F + , encodeDoubleViaWord64F + ) where + +import Foreign +import Data.ByteString.Builder.Prim.Internal + +{- +We work around ticket http://hackage.haskell.org/trac/ghc/ticket/4092 using the +FFI to store the Float/Double in the buffer and peek it out again from there. +-} + + +-- | Encode a 'Float' using a 'Word32' encoding. +-- +-- PRE: The 'Word32' encoding must have a size of at least 4 bytes. +{-# INLINE encodeFloatViaWord32F #-} +encodeFloatViaWord32F :: FixedPrim Word32 -> FixedPrim Float +encodeFloatViaWord32F w32fe + | size w32fe < sizeOf (undefined :: Float) = + error $ "encodeFloatViaWord32F: encoding not wide enough" + | otherwise = fixedEncoding (size w32fe) $ \x op -> do + poke (castPtr op) x + x' <- peek (castPtr op) + runF w32fe x' op + +-- | Encode a 'Double' using a 'Word64' encoding. +-- +-- PRE: The 'Word64' encoding must have a size of at least 8 bytes. +{-# INLINE encodeDoubleViaWord64F #-} +encodeDoubleViaWord64F :: FixedPrim Word64 -> FixedPrim Double +encodeDoubleViaWord64F w64fe + | size w64fe < sizeOf (undefined :: Float) = + error $ "encodeDoubleViaWord64F: encoding not wide enough" + | otherwise = fixedEncoding (size w64fe) $ \x op -> do + poke (castPtr op) x + x' <- peek (castPtr op) + runF w64fe x' op + diff --git a/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs b/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP, MagicHash #-} +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- Original serialization code from 'Data.Binary.Builder': +-- (c) Lennart Kolmodin, Ross Patterson +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Utilty module defining unchecked shifts. +-- +-- These functions are undefined when the amount being shifted by is +-- greater than the size in bits of a machine Int#.- +-- +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.ByteString.Builder.Prim.Internal.UncheckedShifts ( + shiftr_w16 + , shiftr_w32 + , shiftr_w64 + , shiftr_w + + , caseWordSize_32_64 + ) where + + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#else +import Data.Word +#endif + +import Foreign + + +------------------------------------------------------------------------ +-- Unchecked shifts + +-- | Right-shift of a 'Word16'. +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 + +-- | Right-shift of a 'Word32'. +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 + +-- | Right-shift of a 'Word64'. +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +-- | Right-shift of a 'Word'. +{-# INLINE shiftr_w #-} +shiftr_w :: Word -> Int -> Word +#if WORD_SIZE_IN_BITS < 64 +shiftr_w w s = fromIntegral $ (`shiftr_w32` s) $ fromIntegral w +#else +shiftr_w w s = fromIntegral $ (`shiftr_w64` s) $ fromIntegral w +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + + +-- | Select an implementation depending on the bit-size of 'Word's. +-- Currently, it produces a runtime failure if the bitsize is different. +-- This is detected by the testsuite. +{-# INLINE caseWordSize_32_64 #-} +caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's + -> a -- Value to use for 64-bit 'Word's + -> a +caseWordSize_32_64 f32 f64 = case bitSize (undefined :: Word) of + 32 -> f32 + 64 -> f64 + s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s + + diff --git a/Data/ByteString/Char8.hs b/Data/ByteString/Char8.hs --- a/Data/ByteString/Char8.hs +++ b/Data/ByteString/Char8.hs @@ -61,6 +61,7 @@ append, -- :: ByteString -> ByteString -> ByteString head, -- :: ByteString -> Char uncons, -- :: ByteString -> Maybe (Char, ByteString) + unsnoc, -- :: ByteString -> Maybe (ByteString, Char) last, -- :: ByteString -> Char tail, -- :: ByteString -> ByteString init, -- :: ByteString -> ByteString @@ -213,6 +214,7 @@ hGetLine, -- :: Handle -> IO ByteString hGetContents, -- :: Handle -> IO ByteString hGet, -- :: Handle -> Int -> IO ByteString + hGetSome, -- :: Handle -> Int -> IO ByteString hGetNonBlocking, -- :: Handle -> Int -> IO ByteString hPut, -- :: Handle -> ByteString -> IO () hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString @@ -245,7 +247,7 @@ ,findSubstring,findSubstrings,breakSubstring,copy,group ,getLine, getContents, putStr, interact - ,hGetContents, hGet, hPut, hPutStr + ,hGetContents, hGet, hGetSome, hPut, hPutStr ,hGetLine, hGetNonBlocking, hPutNonBlocking ,packCString,packCStringLen ,useAsCString,useAsCStringLen @@ -256,7 +258,7 @@ import Data.Char ( isSpace ) import qualified Data.List as List (intersperse) -import System.IO (Handle,stdout,openFile,hClose,hFileSize,IOMode(..)) +import System.IO (Handle,stdout,openBinaryFile,hClose,hFileSize,IOMode(..)) #ifndef __NHC__ import Control.Exception (bracket) #else @@ -321,6 +323,14 @@ Just (w, bs') -> Just (w2c w, bs') {-# INLINE uncons #-} +-- | /O(1)/ Extract the 'init' and 'last' of a ByteString, returning Nothing +-- if it is empty. +unsnoc :: ByteString -> Maybe (ByteString, Char) +unsnoc bs = case B.unsnoc bs of + Nothing -> Nothing + Just (bs', w) -> Just (bs', w2c w) +{-# INLINE unsnoc #-} + -- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. head :: ByteString -> Char head = w2c . B.head @@ -997,17 +1007,17 @@ -- 'pack'. It also may be more efficient than opening the file and -- reading it using hGet. readFile :: FilePath -> IO ByteString -readFile f = bracket (openFile f ReadMode) hClose +readFile f = bracket (openBinaryFile f ReadMode) hClose (\h -> hFileSize h >>= hGet h . fromIntegral) -- | Write a 'ByteString' to a file. writeFile :: FilePath -> ByteString -> IO () -writeFile f txt = bracket (openFile f WriteMode) hClose +writeFile f txt = bracket (openBinaryFile f WriteMode) hClose (\h -> hPut h txt) -- | Append a 'ByteString' to a file. appendFile :: FilePath -> ByteString -> IO () -appendFile f txt = bracket (openFile f AppendMode) hClose +appendFile f txt = bracket (openBinaryFile f AppendMode) hClose (\h -> hPut h txt) diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -35,9 +35,11 @@ -- * Low level imperative construction create, -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString + createUptoN, -- :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString createAndTrim, -- :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString createAndTrim', -- :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) unsafeCreate, -- :: Int -> (Ptr Word8 -> IO ()) -> ByteString + unsafeCreateUptoN, -- :: Int -> (Ptr Word8 -> IO Int) -> ByteString mallocByteString, -- :: Int -> IO (ForeignPtr a) -- * Conversion to and from ForeignPtrs @@ -240,7 +242,7 @@ packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) packUptoLenBytes len xs0 = - unsafeDupablePerformIO $ create' len $ \p -> go p len xs0 + unsafeCreateUptoN' len $ \p -> go p len xs0 where go !_ !n [] = return (len-n, []) go !_ !0 xs = return (len, xs) @@ -248,7 +250,7 @@ packUptoLenChars :: Int -> [Char] -> (ByteString, [Char]) packUptoLenChars len cs0 = - unsafeDupablePerformIO $ create' len $ \p -> go p len cs0 + unsafeCreateUptoN' len $ \p -> go p len cs0 where go !_ !n [] = return (len-n, []) go !_ !0 cs = return (len, cs) @@ -347,13 +349,23 @@ {-# INLINE toForeignPtr #-} -- | A way of creating ByteStrings outside the IO monad. The @Int@ --- argument gives the final size of the ByteString. Unlike --- 'createAndTrim' the ByteString is not reallocated if the final size --- is less than the estimated size. +-- argument gives the final size of the ByteString. unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString unsafeCreate l f = unsafeDupablePerformIO (create l f) {-# INLINE unsafeCreate #-} +-- | Like 'unsafeCreate' but instead of giving the final size of the +-- ByteString, it is just an upper bound. The inner action returns +-- the actual size. Unlike 'createAndTrim' the ByteString is not +-- reallocated if the final size is less than the estimated size. +unsafeCreateUptoN :: Int -> (Ptr Word8 -> IO Int) -> ByteString +unsafeCreateUptoN l f = unsafeDupablePerformIO (createUptoN l f) +{-# INLINE unsafeCreateUptoN #-} + +unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (ByteString, a) +unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f) +{-# INLINE unsafeCreateUptoN' #-} + #ifndef __GLASGOW_HASKELL__ -- for Hugs, NHC etc unsafeDupablePerformIO :: IO a -> a @@ -368,13 +380,22 @@ return $! PS fp 0 l {-# INLINE create #-} +-- | Create ByteString of up to size size @l@ and use action @f@ to fill it's +-- contents which returns its true size. +createUptoN :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString +createUptoN l f = do + fp <- mallocByteString l + l' <- withForeignPtr fp $ \p -> f p + assert (l' <= l) $ return $! PS fp 0 l' +{-# INLINE createUptoN #-} + -- | Create ByteString of up to size @l@ and use action @f@ to fill it's contents which returns its true size. -create' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a) -create' l f = do +createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a) +createUptoN' l f = do fp <- mallocByteString l (l', res) <- withForeignPtr fp $ \p -> f p assert (l' <= l) $ return (PS fp 0 l', res) -{-# INLINE create' #-} +{-# INLINE createUptoN' #-} -- | Given the maximum size needed and a function to make the contents -- of a ByteString, createAndTrim makes the 'ByteString'. The generating diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs --- a/Data/ByteString/Lazy.hs +++ b/Data/ByteString/Lazy.hs @@ -73,6 +73,7 @@ append, -- :: ByteString -> ByteString -> ByteString head, -- :: ByteString -> Word8 uncons, -- :: ByteString -> Maybe (Word8, ByteString) + unsnoc, -- :: ByteString -> Maybe (ByteString, Word8) last, -- :: ByteString -> Word8 tail, -- :: ByteString -> ByteString init, -- :: ByteString -> ByteString @@ -394,7 +395,7 @@ last :: ByteString -> Word8 last Empty = errorEmptyList "last" last (Chunk c0 cs0) = go c0 cs0 - where go c Empty = S.last c + where go c Empty = S.unsafeLast c go _ (Chunk c cs) = go c cs -- XXX Don't inline this. Something breaks with 6.8.2 (haven't investigated yet) @@ -403,9 +404,17 @@ init Empty = errorEmptyList "init" init (Chunk c0 cs0) = go c0 cs0 where go c Empty | S.length c == 1 = Empty - | otherwise = Chunk (S.init c) Empty + | otherwise = Chunk (S.unsafeInit c) Empty go c (Chunk c' cs) = Chunk c (go c' cs) +-- | /O(n\/c)/ Extract the 'init' and 'last' of a ByteString, returning Nothing +-- if it is empty. +-- +-- * It is no faster than using 'init' and 'last' +unsnoc :: ByteString -> Maybe (ByteString, Word8) +unsnoc Empty = Nothing +unsnoc (Chunk c cs) = Just (init (Chunk c cs), last (Chunk c cs)) + -- | /O(n\/c)/ Append two ByteStrings append :: ByteString -> ByteString -> ByteString append = mappend @@ -482,6 +491,7 @@ -- | 'foldl1' is a variant of 'foldl' that has no starting value -- argument, and thus must be applied to non-empty 'ByteStrings'. +-- This function is subject to array fusion. foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldl1 _ Empty = errorEmptyList "foldl1" foldl1 f (Chunk c cs) = foldl f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) diff --git a/Data/ByteString/Lazy/Builder.hs b/Data/ByteString/Lazy/Builder.hs --- a/Data/ByteString/Lazy/Builder.hs +++ b/Data/ByteString/Lazy/Builder.hs @@ -1,451 +1,11 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{- | Copyright : (c) 2010 Jasper Van der Jeugt - (c) 2010 - 2011 Simon Meier -License : BSD3-style (see LICENSE) -Maintainer : Simon Meier -Portability : GHC -'Builder's are used to efficiently construct sequences of bytes from - smaller parts. -Typically, - such a construction is part of the implementation of an /encoding/, i.e., - a function for converting Haskell values to sequences of bytes. -Examples of encodings are the generation of the sequence of bytes - representing a HTML document to be sent in a HTTP response by a - web application or the serialization of a Haskell value using - a fixed binary format. - -For an /efficient implementation of an encoding/, - it is important that (a) little time is spent on converting - the Haskell values to the resulting sequence of bytes /and/ - (b) that the representation of the resulting sequence - is such that it can be consumed efficiently. -'Builder's support (a) by providing an /O(1)/ concatentation operation - and efficient implementations of basic encodings for 'Char's, 'Int's, - and other standard Haskell values. -They support (b) by providing their result as a lazy 'L.ByteString', - which is internally just a linked list of pointers to /chunks/ - of consecutive raw memory. -Lazy 'L.ByteString's can be efficiently consumed by functions that - write them to a file or send them over a network socket. -Note that each chunk boundary incurs expensive extra work (e.g., a system call) - that must be amortized over the work spent on consuming the chunk body. -'Builder's therefore take special care to ensure that the - average chunk size is large enough. -The precise meaning of large enough is application dependent. -The current implementation is tuned - for an average chunk size between 4kb and 32kb, - which should suit most applications. - -As a simple example of an encoding implementation, - we show how to efficiently convert the following representation of mixed-data - tables to an UTF-8 encoded Comma-Separated-Values (CSV) table. - ->data Cell = StringC String -> | IntC Int -> deriving( Eq, Ord, Show ) -> ->type Row = [Cell] ->type Table = [Row] - -We use the following imports and abbreviate 'mappend' to simplify reading. - -@ -import qualified "Data.ByteString.Lazy" as L -import "Data.ByteString.Lazy.Builder" -import "Data.ByteString.Lazy.Builder.ASCII" ('intDec') -import Data.Monoid -import Data.Foldable ('foldMap') -import Data.List ('intersperse') - -infixr 4 \<\> -(\<\>) :: 'Monoid' m => m -> m -> m -(\<\>) = 'mappend' -@ - -CSV is a character-based representation of tables. For maximal modularity, -we could first render 'Table's as 'String's and then encode this 'String' -using some Unicode character encoding. However, this sacrifices performance -due to the intermediate 'String' representation being built and thrown away -right afterwards. We get rid of this intermediate 'String' representation by -fixing the character encoding to UTF-8 and using 'Builder's to convert -'Table's directly to UTF-8 encoded CSV tables represented as lazy -'L.ByteString's. - -@ -encodeUtf8CSV :: Table -> L.ByteString -encodeUtf8CSV = 'toLazyByteString' . renderTable - -renderTable :: Table -> Builder -renderTable rs = 'mconcat' [renderRow r \<\> 'charUtf8' \'\\n\' | r <- rs] - -renderRow :: Row -> Builder -renderRow [] = 'mempty' -renderRow (c:cs) = - renderCell c \<\> mconcat [ charUtf8 \',\' \<\> renderCell c\' | c\' <- cs ] - -renderCell :: Cell -> Builder -renderCell (StringC cs) = renderString cs -renderCell (IntC i) = 'intDec' i - -renderString :: String -> Builder -renderString cs = charUtf8 \'\"\' \<\> foldMap escape cs \<\> charUtf8 \'\"\' - where - escape \'\\\\\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\\\' - escape \'\\\"\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\"\' - escape c = charUtf8 c -@ - -Note that the ASCII encoding is a subset of the UTF-8 encoding, - which is why we can use the optimized function 'intDec' to - encode an 'Int' as a decimal number with UTF-8 encoded digits. -Using 'intDec' is more efficient than @'stringUtf8' . 'show'@, - as it avoids constructing an intermediate 'String'. -Avoiding this intermediate data structure significantly improves - performance because encoding 'Cell's is the core operation - for rendering CSV-tables. -See "Data.ByteString.Lazy.Builder.BasicEncoding" for further - information on how to improve the performance of 'renderString'. - -We demonstrate our UTF-8 CSV encoding function on the following table. - -@ -strings :: [String] -strings = [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] - -table :: Table -table = [map StringC strings, map IntC [-3..3]] -@ - -The expression @encodeUtf8CSV table@ results in the following lazy -'L.ByteString'. - ->Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty - -We can clearly see that we are converting to a /binary/ format. The \'λ\' -and \'ö\' characters, which have a Unicode codepoint above 127, are -expanded to their corresponding UTF-8 multi-byte representation. - -We use the @criterion@ library () - to benchmark the efficiency of our encoding function on the following table. - ->import Criterion.Main -- add this import to the ones above -> ->maxiTable :: Table ->maxiTable = take 1000 $ cycle table -> ->main :: IO () ->main = defaultMain -> [ bench "encodeUtf8CSV maxiTable (original)" $ -> whnf (L.length . encodeUtf8CSV) maxiTable -> ] - -On a Core2 Duo 2.20GHz on a 32-bit Linux, - the above code takes 1ms to generate the 22'500 bytes long lazy 'L.ByteString'. -Looking again at the definitions above, - we see that we took care to avoid intermediate data structures, - as otherwise we would sacrifice performance. -For example, - the following (arguably simpler) definition of 'renderRow' is about 20% slower. - ->renderRow :: Row -> Builder ->renderRow = mconcat . intersperse (charUtf8 ',') . map renderCell - -Similarly, using /O(n)/ concatentations like '++' or the equivalent 'S.concat' - operations on strict and lazy 'L.ByteString's should be avoided. -The following definition of 'renderString' is also about 20% slower. - ->renderString :: String -> Builder ->renderString cs = charUtf8 $ "\"" ++ concatMap escape cs ++ "\"" -> where -> escape '\\' = "\\" -> escape '\"' = "\\\"" -> escape c = return c - -Apart from removing intermediate data-structures, - encodings can be optimized further by fine-tuning their execution - parameters using the functions in "Data.ByteString.Lazy.Builder.Extras" and - their \"inner loops\" using the functions in - "Data.ByteString.Lazy.Builder.BasicEncoding". --} - - -module Data.ByteString.Lazy.Builder - ( - -- * The Builder type - Builder - - -- * Executing Builders - -- | Internally, 'Builder's are buffer-filling functions. They are - -- executed by a /driver/ that provides them with an actual buffer to - -- fill. Once called with a buffer, a 'Builder' fills it and returns a - -- signal to the driver telling it that it is either done, has filled the - -- current buffer, or wants to directly insert a reference to a chunk of - -- memory. In the last two cases, the 'Builder' also returns a - -- continutation 'Builder' that the driver can call to fill the next - -- buffer. Here, we provide the two drivers that satisfy almost all use - -- cases. See "Data.ByteString.Lazy.Builder.Extras", for information - -- about fine-tuning them. - , toLazyByteString - , hPutBuilder - - -- * Creating Builders - - -- ** Binary encodings - , byteString - , lazyByteString - , int8 - , word8 - - -- *** Big-endian - , int16BE - , int32BE - , int64BE - - , word16BE - , word32BE - , word64BE - - , floatBE - , doubleBE - - -- *** Little-endian - , int16LE - , int32LE - , int64LE - - , word16LE - , word32LE - , word64LE - - , floatLE - , doubleLE - - -- ** Character encodings - - -- *** ASCII (Char7) - -- | The ASCII encoding is a 7-bit encoding. The /Char7/ encoding implemented here - -- works by truncating the Unicode codepoint to 7-bits, prefixing it - -- with a leading 0, and encoding the resulting 8-bits as a single byte. - -- For the codepoints 0-127 this corresponds the ASCII encoding. In - -- "Data.ByteString.Lazy.Builder.ASCII", we also provide efficient - -- implementations of ASCII-based encodings of numbers (e.g., decimal and - -- hexadecimal encodings). - , char7 - , string7 - - -- *** ISO/IEC 8859-1 (Char8) - -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. - -- The /Char8/ encoding implemented here works by truncating the Unicode codepoint - -- to 8-bits and encoding them as a single byte. For the codepoints 0-255 this corresponds - -- to the ISO/IEC 8859-1 encoding. Note that you can also use - -- the functions from "Data.ByteString.Lazy.Builder.ASCII", as the ASCII encoding - -- and ISO/IEC 8859-1 are equivalent on the codepoints 0-127. - , char8 - , string8 - - -- *** UTF-8 - -- | The UTF-8 encoding can encode /all/ Unicode codepoints. We recommend - -- using it always for encoding 'Char's and 'String's unless an application - -- really requires another encoding. Note that you can also use the - -- functions from "Data.ByteString.Lazy.Builder.ASCII" for UTF-8 encoding, - -- as the ASCII encoding is equivalent to the UTF-8 encoding on the Unicode - -- codepoints 0-127. - , charUtf8 - , stringUtf8 - - - ) where - -import Data.ByteString.Lazy.Builder.Internal -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import qualified Data.ByteString.Lazy.Internal as L - -import System.IO (Handle) -import Foreign - --- HADDOCK only imports -import Data.ByteString.Lazy.Builder.ASCII (intDec) -import qualified Data.ByteString as S (concat) -import Data.Monoid -import Data.Foldable (foldMap) -import Data.List (intersperse) - - --- | Execute a 'Builder' and return the generated chunks as a lazy 'L.ByteString'. --- The work is performed lazy, i.e., only when a chunk of the lazy 'L.ByteString' --- is forced. -{-# NOINLINE toLazyByteString #-} -- ensure code is shared -toLazyByteString :: Builder -> L.ByteString -toLazyByteString = toLazyByteStringWith - (safeStrategy L.smallChunkSize L.defaultChunkSize) L.Empty - -{- Not yet stable enough. - See note on 'hPut' in Data.ByteString.Lazy.Builder.Internal --} - --- | Output a 'Builder' to a 'Handle'. --- The 'Builder' is executed directly on the buffer of the 'Handle'. If the --- buffer is too small (or not present), then it is replaced with a large --- enough buffer. --- --- It is recommended that the 'Handle' is set to binary and --- 'BlockBuffering' mode. See 'hSetBinaryMode' and 'hSetBuffering'. --- --- This function is more efficient than @hPut . 'toLazyByteString'@ because in --- many cases no buffer allocation has to be done. Moreover, the results of --- several executions of short 'Builder's are concatenated in the 'Handle's --- buffer, therefore avoiding unnecessary buffer flushes. -hPutBuilder :: Handle -> Builder -> IO () -hPutBuilder h = hPut h . putBuilder - - ------------------------------------------------------------------------------- --- Binary encodings ------------------------------------------------------------------------------- - --- | Encode a single signed byte as-is. +-- | We decided to rename the Builder modules. Sorry about that. -- -{-# INLINE int8 #-} -int8 :: Int8 -> Builder -int8 = E.encodeWithF E.int8 - --- | Encode a single unsigned byte as-is. +-- The old names will hang about for at least once release cycle before we +-- deprecate them and then later remove them. -- -{-# INLINE word8 #-} -word8 :: Word8 -> Builder -word8 = E.encodeWithF E.word8 - - ------------------------------------------------------------------------------- --- Binary little-endian encodings ------------------------------------------------------------------------------- - --- | Encode an 'Int16' in little endian format. -{-# INLINE int16LE #-} -int16LE :: Int16 -> Builder -int16LE = E.encodeWithF E.int16LE - --- | Encode an 'Int32' in little endian format. -{-# INLINE int32LE #-} -int32LE :: Int32 -> Builder -int32LE = E.encodeWithF E.int32LE - --- | Encode an 'Int64' in little endian format. -{-# INLINE int64LE #-} -int64LE :: Int64 -> Builder -int64LE = E.encodeWithF E.int64LE - --- | Encode a 'Word16' in little endian format. -{-# INLINE word16LE #-} -word16LE :: Word16 -> Builder -word16LE = E.encodeWithF E.word16LE - --- | Encode a 'Word32' in little endian format. -{-# INLINE word32LE #-} -word32LE :: Word32 -> Builder -word32LE = E.encodeWithF E.word32LE - --- | Encode a 'Word64' in little endian format. -{-# INLINE word64LE #-} -word64LE :: Word64 -> Builder -word64LE = E.encodeWithF E.word64LE - --- | Encode a 'Float' in little endian format. -{-# INLINE floatLE #-} -floatLE :: Float -> Builder -floatLE = E.encodeWithF E.floatLE - --- | Encode a 'Double' in little endian format. -{-# INLINE doubleLE #-} -doubleLE :: Double -> Builder -doubleLE = E.encodeWithF E.doubleLE - - ------------------------------------------------------------------------------- --- Binary big-endian encodings ------------------------------------------------------------------------------- - --- | Encode an 'Int16' in big endian format. -{-# INLINE int16BE #-} -int16BE :: Int16 -> Builder -int16BE = E.encodeWithF E.int16BE - --- | Encode an 'Int32' in big endian format. -{-# INLINE int32BE #-} -int32BE :: Int32 -> Builder -int32BE = E.encodeWithF E.int32BE - --- | Encode an 'Int64' in big endian format. -{-# INLINE int64BE #-} -int64BE :: Int64 -> Builder -int64BE = E.encodeWithF E.int64BE - --- | Encode a 'Word16' in big endian format. -{-# INLINE word16BE #-} -word16BE :: Word16 -> Builder -word16BE = E.encodeWithF E.word16BE - --- | Encode a 'Word32' in big endian format. -{-# INLINE word32BE #-} -word32BE :: Word32 -> Builder -word32BE = E.encodeWithF E.word32BE - --- | Encode a 'Word64' in big endian format. -{-# INLINE word64BE #-} -word64BE :: Word64 -> Builder -word64BE = E.encodeWithF E.word64BE - --- | Encode a 'Float' in big endian format. -{-# INLINE floatBE #-} -floatBE :: Float -> Builder -floatBE = E.encodeWithF E.floatBE - --- | Encode a 'Double' in big endian format. -{-# INLINE doubleBE #-} -doubleBE :: Double -> Builder -doubleBE = E.encodeWithF E.doubleBE - ------------------------------------------------------------------------------- --- ASCII encoding ------------------------------------------------------------------------------- - --- | Char7 encode a 'Char'. -{-# INLINE char7 #-} -char7 :: Char -> Builder -char7 = E.encodeWithF E.char7 - --- | Char7 encode a 'String'. -{-# INLINE string7 #-} -string7 :: String -> Builder -string7 = E.encodeListWithF E.char7 - ------------------------------------------------------------------------------- --- ISO/IEC 8859-1 encoding ------------------------------------------------------------------------------- - --- | Char8 encode a 'Char'. -{-# INLINE char8 #-} -char8 :: Char -> Builder -char8 = E.encodeWithF E.char8 - --- | Char8 encode a 'String'. -{-# INLINE string8 #-} -string8 :: String -> Builder -string8 = E.encodeListWithF E.char8 - ------------------------------------------------------------------------------- --- UTF-8 encoding ------------------------------------------------------------------------------- - --- | UTF-8 encode a 'Char'. -{-# INLINE charUtf8 #-} -charUtf8 :: Char -> Builder -charUtf8 = E.encodeWithB E.charUtf8 - --- | UTF-8 encode a 'String'. -{-# INLINE stringUtf8 #-} -stringUtf8 :: String -> Builder -stringUtf8 = E.encodeListWithB E.charUtf8 +module Data.ByteString.Lazy.Builder ( + module Data.ByteString.Builder +) where +import Data.ByteString.Builder diff --git a/Data/ByteString/Lazy/Builder/ASCII.hs b/Data/ByteString/Lazy/Builder/ASCII.hs --- a/Data/ByteString/Lazy/Builder/ASCII.hs +++ b/Data/ByteString/Lazy/Builder/ASCII.hs @@ -1,268 +1,14 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} --- | Copyright : (c) 2010 - 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Constructing 'Builder's using ASCII-based encodings. --- -module Data.ByteString.Lazy.Builder.ASCII - ( - -- * Decimal numbers - -- | Decimal encoding of numbers using ASCII encoded characters. - int8Dec - , int16Dec - , int32Dec - , int64Dec - , intDec - , integerDec - , word8Dec - , word16Dec - , word32Dec - , word64Dec - , wordDec - - , floatDec - , doubleDec - - -- * Hexadecimal numbers - - -- | Encoding positive integers as hexadecimal numbers using lower-case - -- ASCII characters. The shortest - -- possible representation is used. For example, - -- - -- >>> toLazyByteString (word16Hex 0x0a10) - -- Chunk "a10" Empty - -- - -- Note that there is no support for using upper-case characters. Please - -- contact the maintainer, if your application cannot work without - -- hexadecimal encodings that use upper-case characters. - -- - , word8Hex - , word16Hex - , word32Hex - , word64Hex - , wordHex - - -- * Fixed-width hexadecimal numbers - -- - , int8HexFixed - , int16HexFixed - , int32HexFixed - , int64HexFixed - , word8HexFixed - , word16HexFixed - , word32HexFixed - , word64HexFixed - - , floatHexFixed - , doubleHexFixed - - , byteStringHexFixed - , lazyByteStringHexFixed - - ) where - -import Data.ByteString as S -import Data.ByteString.Lazy.Internal as L -import Data.ByteString.Lazy.Builder.Internal (Builder) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E - -import Foreign - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - - --- | Encode a 'String' using 'E.char7'. -{-# INLINE string7 #-} -string7 :: String -> Builder -string7 = E.encodeListWithF E.char7 - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - --- Signed integers ------------------- - --- | Decimal encoding of an 'Int8' using the ASCII digits. +-- | We decided to rename the Builder modules. Sorry about that. -- --- e.g. +-- In additon, the ASCII module has been merged into the main +-- "Data.ByteString.Builder" module. -- --- > toLazyByteString (int8Dec 42) = "42" --- > toLazyByteString (int8Dec (-1)) = "-1" +-- The old names will hang about for at least once release cycle before we +-- deprecate them and then later remove them. -- -{-# INLINE int8Dec #-} -int8Dec :: Int8 -> Builder -int8Dec = E.encodeWithB E.int8Dec - --- | Decimal encoding of an 'Int16' using the ASCII digits. -{-# INLINE int16Dec #-} -int16Dec :: Int16 -> Builder -int16Dec = E.encodeWithB E.int16Dec - --- | Decimal encoding of an 'Int32' using the ASCII digits. -{-# INLINE int32Dec #-} -int32Dec :: Int32 -> Builder -int32Dec = E.encodeWithB E.int32Dec - --- | Decimal encoding of an 'Int64' using the ASCII digits. -{-# INLINE int64Dec #-} -int64Dec :: Int64 -> Builder -int64Dec = E.encodeWithB E.int64Dec - --- | Decimal encoding of an 'Int' using the ASCII digits. -{-# INLINE intDec #-} -intDec :: Int -> Builder -intDec = E.encodeWithB E.intDec - --- | /Currently slow./ Decimal encoding of an 'Integer' using the ASCII digits. -{-# INLINE integerDec #-} -integerDec :: Integer -> Builder -integerDec = string7 . show - - --- Unsigned integers --------------------- - --- | Decimal encoding of a 'Word8' using the ASCII digits. -{-# INLINE word8Dec #-} -word8Dec :: Word8 -> Builder -word8Dec = E.encodeWithB E.word8Dec - --- | Decimal encoding of a 'Word16' using the ASCII digits. -{-# INLINE word16Dec #-} -word16Dec :: Word16 -> Builder -word16Dec = E.encodeWithB E.word16Dec - --- | Decimal encoding of a 'Word32' using the ASCII digits. -{-# INLINE word32Dec #-} -word32Dec :: Word32 -> Builder -word32Dec = E.encodeWithB E.word32Dec - --- | Decimal encoding of a 'Word64' using the ASCII digits. -{-# INLINE word64Dec #-} -word64Dec :: Word64 -> Builder -word64Dec = E.encodeWithB E.word64Dec - --- | Decimal encoding of a 'Word' using the ASCII digits. -{-# INLINE wordDec #-} -wordDec :: Word -> Builder -wordDec = E.encodeWithB E.wordDec - - --- Floating point numbers -------------------------- - --- TODO: Use Bryan O'Sullivan's double-conversion package to speed it up. - --- | /Currently slow./ Decimal encoding of an IEEE 'Float'. -{-# INLINE floatDec #-} -floatDec :: Float -> Builder -floatDec = string7 . show - --- | /Currently slow./ Decimal encoding of an IEEE 'Double'. -{-# INLINE doubleDec #-} -doubleDec :: Double -> Builder -doubleDec = string7 . show - - ------------------------------------------------------------------------------- --- Hexadecimal Encoding ------------------------------------------------------------------------------- - --- without lead ---------------- - --- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters. -{-# INLINE word8Hex #-} -word8Hex :: Word8 -> Builder -word8Hex = E.encodeWithB E.word8Hex - --- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters. -{-# INLINE word16Hex #-} -word16Hex :: Word16 -> Builder -word16Hex = E.encodeWithB E.word16Hex - --- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters. -{-# INLINE word32Hex #-} -word32Hex :: Word32 -> Builder -word32Hex = E.encodeWithB E.word32Hex - --- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters. -{-# INLINE word64Hex #-} -word64Hex :: Word64 -> Builder -word64Hex = E.encodeWithB E.word64Hex - --- | Shortest hexadecimal encoding of a 'Word' using lower-case characters. -{-# INLINE wordHex #-} -wordHex :: Word -> Builder -wordHex = E.encodeWithB E.wordHex - - --- fixed width; leading zeroes ------------------------------- - --- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). -{-# INLINE int8HexFixed #-} -int8HexFixed :: Int8 -> Builder -int8HexFixed = E.encodeWithF E.int8HexFixed - --- | Encode a 'Int16' using 4 nibbles. -{-# INLINE int16HexFixed #-} -int16HexFixed :: Int16 -> Builder -int16HexFixed = E.encodeWithF E.int16HexFixed - --- | Encode a 'Int32' using 8 nibbles. -{-# INLINE int32HexFixed #-} -int32HexFixed :: Int32 -> Builder -int32HexFixed = E.encodeWithF E.int32HexFixed - --- | Encode a 'Int64' using 16 nibbles. -{-# INLINE int64HexFixed #-} -int64HexFixed :: Int64 -> Builder -int64HexFixed = E.encodeWithF E.int64HexFixed - --- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). -{-# INLINE word8HexFixed #-} -word8HexFixed :: Word8 -> Builder -word8HexFixed = E.encodeWithF E.word8HexFixed - --- | Encode a 'Word16' using 4 nibbles. -{-# INLINE word16HexFixed #-} -word16HexFixed :: Word16 -> Builder -word16HexFixed = E.encodeWithF E.word16HexFixed - --- | Encode a 'Word32' using 8 nibbles. -{-# INLINE word32HexFixed #-} -word32HexFixed :: Word32 -> Builder -word32HexFixed = E.encodeWithF E.word32HexFixed - --- | Encode a 'Word64' using 16 nibbles. -{-# INLINE word64HexFixed #-} -word64HexFixed :: Word64 -> Builder -word64HexFixed = E.encodeWithF E.word64HexFixed - --- | Encode an IEEE 'Float' using 8 nibbles. -{-# INLINE floatHexFixed #-} -floatHexFixed :: Float -> Builder -floatHexFixed = E.encodeWithF E.floatHexFixed - --- | Encode an IEEE 'Double' using 16 nibbles. -{-# INLINE doubleHexFixed #-} -doubleHexFixed :: Double -> Builder -doubleHexFixed = E.encodeWithF E.doubleHexFixed - --- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding. -{-# NOINLINE byteStringHexFixed #-} -- share code -byteStringHexFixed :: S.ByteString -> Builder -byteStringHexFixed = E.encodeByteStringWithF E.word8HexFixed +module Data.ByteString.Lazy.Builder.ASCII ( + module Data.ByteString.Builder +) where --- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding. -{-# NOINLINE lazyByteStringHexFixed #-} -- share code -lazyByteStringHexFixed :: L.ByteString -> Builder -lazyByteStringHexFixed = E.encodeLazyByteStringWithF E.word8HexFixed +import Data.ByteString.Builder diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding.hs b/Data/ByteString/Lazy/Builder/BasicEncoding.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding.hs +++ /dev/null @@ -1,804 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{- | Copyright : (c) 2010-2011 Simon Meier - (c) 2010 Jasper van der Jeugt -License : BSD3-style (see LICENSE) -Maintainer : Simon Meier -Portability : GHC - -This module provides the types of fixed-size and bounded-size encodings, - which are the basic building blocks for constructing 'Builder's. -These types are used to achieve - application-specific performance improvements of 'Builder's. - -/Fixed(-size) encodings/ are encodings that always result in a sequence of bytes - of a predetermined, fixed length. -An example for a fixed encoding is the big-endian encoding of a 'Word64', - which always results in exactly 8 bytes. -/Bounded(-size) encodings/ are encodings that always result in a sequence - of bytes that is no larger than a predetermined bound. -An example for a bounded encoding is the UTF-8 encoding of a 'Char', - which results always in less or equal to 4 bytes. -Note that every fixed encoding is also a bounded encoding. -In the following, we therefore only refer to fixed encodings, - where it matters that the resulting sequence of bytes is of a - of a predetermined, fixed length. -Otherwise, we just refer to bounded encodings. - -As said, - the goal of bounded encodings is to improve the performance of 'Builder's. -These improvements stem from making the two - most common steps performed by a 'Builder' more efficient. -We explain these two steps in turn. - -The first most common step is the concatentation of two 'Builder's. -Internally, - concatentation corresponds to function composition. -(Note that 'Builder's can be seen as difference-lists - of buffer-filling functions; - cf. . -) -Function composition is a fast /O(1)/ operation. -However, - we can use bounded encodings to - remove some of these function compositions altoghether, - which is obviously more efficient. - -The second most common step performed by a 'Builder' is to fill a buffer - using a bounded encoding, - which works as follows. -The 'Builder' checks whether there is enough space left to - execute the bounded encoding. -If there is, then the 'Builder' executes the bounded encoding - and calls the next 'Builder' with the updated buffer. -Otherwise, - the 'Builder' signals its driver that it requires a new buffer. -This buffer must be at least as large as the bound of the encoding. -We can use bounded encodings to reduce the number of buffer-free - checks by fusing the buffer-free checks of consecutive - 'Builder's. -We can also use bounded encodings to simplify the control flow - for signalling that a buffer is full by - ensuring that we check first that there is enough space left - and only then decide on how to encode a given value. - -Let us illustrate these improvements on the - CSV-table rendering example from "Data.ByteString.Lazy.Builder". -Its \"hot code\" is the rendering of a table's cells, - which we implement as follows using only the functions from the - 'Builder' API. - -@ -import "Data.ByteString.Lazy.Builder" as B -import "Data.ByteString.Lazy.Builder.ASCII" as B - -renderCell :: Cell -> Builder -renderCell (StringC cs) = renderString cs -renderCell (IntC i) = B.intDec i - -renderString :: String -> Builder -renderString cs = B.charUtf8 \'\"\' \<\> foldMap escape cs \<\> B.charUtf8 \'\"\' - where - escape \'\\\\\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\\\' - escape \'\\\"\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\"\' - escape c = B.charUtf8 c -@ - -Efficient encoding of 'Int's as decimal numbers is performed by @intDec@ - from "Data.ByteString.Lazy.Builder.ASCII". -Optimization potential exists for the escaping of 'String's. -The above implementation has two optimization opportunities. -First, - the buffer-free checks of the 'Builder's for escaping doublequotes - and backslashes can be fused. -Second, - the concatenations performed by 'foldMap' can be eliminated. -The following implementation exploits these optimizations. - -@ -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import Data.ByteString.Lazy.Builder.BasicEncoding - ( 'ifB', 'fromF', ('>*<'), ('>$<') ) - -renderString :: String -\> Builder -renderString cs = - B.charUtf8 \'\"\' \<\> E.'encodeListWithB' escape cs \<\> B.charUtf8 \'\"\' - where - escape :: E.'BoundedEncoding' Char - escape = - 'ifB' (== \'\\\\\') (fixed2 (\'\\\\\', \'\\\\\')) $ - 'ifB' (== \'\\\"\') (fixed2 (\'\\\\\', \'\\\"\')) $ - E.'charUtf8' -   - {-\# INLINE fixed2 \#-} - fixed2 x = 'fromF' $ const x '>$<' E.'char7' '>*<' E.'char7' -@ - -The code should be mostly self-explanatory. -The slightly awkward syntax is because the combinators - are written such that the size-bound of the resulting 'BoundedEncoding' - can be computed at compile time. -We also explicitly inline the 'fixed2' encoding, - which encodes a fixed tuple of characters, - to ensure that the bound compuation happens at compile time. -When encoding the following list of 'String's, - the optimized implementation of 'renderString' is two times faster. - -@ -maxiStrings :: [String] -maxiStrings = take 1000 $ cycle [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] -@ - -Most of the performance gain stems from using 'encodeListWithB', - which encodes a list of values from left-to-right with a - 'BoundedEncoding'. -It exploits the 'Builder' internals to avoid unnecessary function - compositions (i.e., concatentations). -In the future, - we would expect the compiler to perform the optimizations - implemented in 'encodeListWithB'. -However, - it seems that the code is currently to complicated for the - compiler to see through. -Therefore, - we provide the 'BoundedEncoding' escape hatch, - which allows data structures to provide very efficient encoding traversals, - like 'encodeListWithB' for lists. - -Note that 'BoundedEncoding's are a bit verbose, but quite versatile. -Here is an example of a 'BoundedEncoding' for combined HTML escapng and -UTF-8 encoding. -It exploits that the escaped character with the maximal Unicode - codepoint is \'>\'. - -@ -{-\# INLINE charUtf8HtmlEscaped \#-} -charUtf8HtmlEscaped :: E.BoundedEncoding Char -charUtf8HtmlEscaped = - 'ifB' (> \'\>\' ) E.'charUtf8' $ - 'ifB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $ -- < - 'ifB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $ -- > - 'ifB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $ -- & - 'ifB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $ -- &\#34; - 'ifB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $ -- &\#39; - ('fromF' E.'char7') -- fallback for 'Char's smaller than \'\>\' - where - {-\# INLINE fixed4 \#-} - fixed4 x = 'fromF' $ const x '>$<' - E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 -   - {-\# INLINE fixed5 \#-} - fixed5 x = 'fromF' $ const x '>$<' - E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 -@ - -This module currently does not expose functions that require the special - properties of fixed-size encodings. -They are useful for prefixing 'Builder's with their size or for - implementing chunked encodings. -We will expose the corresponding functions in future releases of this - library. --} - - - -{- --- --- --- A /bounded encoding/ is an encoding that never results in a sequence --- longer than some fixed number of bytes. This number of bytes must be --- independent of the value being encoded. Typical examples of bounded --- encodings are the big-endian encoding of a 'Word64', which results always --- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always --- in less or equal to 4 bytes. --- --- Typically, encodings are implemented efficiently by allocating a buffer (an --- array of bytes) and repeatedly executing the following two steps: (1) --- writing to the buffer until it is full and (2) handing over the filled part --- to the consumer of the encoded value. Step (1) is where bounded encodings --- are used. We must use a bounded encoding, as we must check that there is --- enough free space /before/ actually writing to the buffer. --- --- In term of expressivity, it would be sufficient to construct all encodings --- from the single bounded encoding that encodes a 'Word8' as-is. However, --- this is not sufficient in terms of efficiency. It results in unnecessary --- buffer-full checks and it complicates the program-flow for writing to the --- buffer, as buffer-full checks are interleaved with analyzing the value to be --- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a --- significant effect on overall encoding performance, as encoding primitive --- Haskell values such as 'Word8's or 'Char's lies at the heart of every --- encoding implementation. --- --- The bounded 'Encoding's provided by this module remove this performance --- problem. Intuitively, they consist of a tuple of the bound on the maximal --- number of bytes written and the actual implementation of the encoding as a --- function that modifies a mutable buffer. Hence when executing a bounded --- 'Encoding', the buffer-full check can be done once before the actual writing --- to the buffer. The provided 'Encoding's also take care to implement the --- actual writing to the buffer efficiently. Moreover, combinators are --- provided to construct new bounded encodings from the provided ones. --- --- A typical example for using the combinators is a bounded 'Encoding' that --- combines escaping the ' and \\ characters with UTF-8 encoding. More --- precisely, the escaping to be done is the one implemented by the following --- @escape@ function. --- --- > escape :: Char -> [Char] --- > escape '\'' = "\\'" --- > escape '\\' = "\\\\" --- > escape c = [c] --- --- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is --- the following. --- --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > {-# INLINE escapeChar #-} --- > escapeUtf8 :: BoundedEncoding Char --- > escapeUtf8 = --- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ --- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ --- > char --- --- The definition of 'escapeUtf8' is more complicated than 'escape', because --- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in --- 'escapeChar' compute both the bound on the maximal number of bytes written --- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required --- to implement the encoding. Bounded 'Encoding's should always be inlined. --- Otherwise, the compiler cannot compute the bound on the maximal number of --- bytes written at compile-time. Without inlinining, it would also fail to --- optimize the constant encoding of the escape characters in the above --- example. Functions that execute bounded 'Encoding's also perform --- suboptimally, if the definition of the bounded 'Encoding' is not inlined. --- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. --- --- Currently, the only library that executes bounded 'Encoding's is the --- 'bytestring' library (). It --- uses bounded 'Encoding's to implement most of its lazy bytestring builders. --- Executing a bounded encoding should be done using the corresponding --- functions in the lazy bytestring builder 'Extras' module. --- --- TODO: Merge with explanation/example below --- --- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by --- writing a bounded-size sequence of bytes directly to memory. They are --- lifted to conversions from Haskell values to 'Builder's by wrapping them --- with a bound-check. The compiler can implement this bound-check very --- efficiently (i.e, a single comparison of the difference of two pointers to a --- constant), because the bound of a 'E.Encoding' is always independent of the --- value being encoded and, in most cases, a literal constant. --- --- 'E.Encoding's are the primary means for defining conversion functions from --- primitive Haskell values to 'Builder's. Most 'Builder' constructors --- provided by this library are implemented that way. --- 'E.Encoding's are also used to construct conversions that exploit the internal --- representation of data-structures. --- --- For example, 'encodeByteStringWith' works directly on the underlying byte --- array and uses some tricks to reduce the number of variables in its inner --- loop. Its efficiency is exploited for implementing the @filter@ and @map@ --- functions in "Data.ByteString.Lazy" as --- --- > import qualified Codec.Bounded.Encoding as E --- > --- > filter :: (Word8 -> Bool) -> ByteString -> ByteString --- > filter p = toLazyByteString . encodeLazyByteStringWithB write --- > where --- > write = E.encodeIf p E.word8 E.emptyEncoding --- > --- > map :: (Word8 -> Word8) -> ByteString -> ByteString --- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) --- --- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, --- these versions use a more efficient inner loop and have the additional --- advantage that they always result in well-chunked 'L.ByteString's; i.e, they --- also perform automatic defragmentation. --- --- We can also use 'E.Encoding's to improve the efficiency of the following --- 'renderString' function from our UTF-8 CSV table encoding example in --- "Data.ByteString.Lazy.Builder". --- --- > renderString :: String -> Builder --- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' --- > where --- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' --- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' --- > escape c = charUtf8 c --- --- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes --- characters and using 'encodeListWith', which implements writing a list of --- values with a tighter inner loop and no 'mappend'. --- --- > import Data.ByteString.Lazy.Builder.Extras -- assume these three --- > import Codec.Bounded.Encoding -- imports are present --- > ( BoundedEncoding, encodeIf, (<#>), (#.) ) --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > renderString :: String -> Builder --- > renderString cs = --- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' --- > where --- > escapedUtf8 :: BoundedEncoding Char --- > escapedUtf8 = --- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ --- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ --- > char --- --- This 'Builder' considers a buffer with less than 8 free bytes as full. As --- all functions are inlined, the compiler is able to optimize the constant --- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of --- 'renderString' this implementation is 1.7x faster. --- --} -{- -Internally, 'Builder's are buffer-fill operations that are -given a continuation buffer-fill operation and a buffer-range to be filled. -A 'Builder' first checks if the buffer-range is large enough. If that's -the case, the 'Builder' writes the sequences of bytes to the buffer and -calls its continuation. Otherwise, it returns a signal that it requires a -new buffer together with a continuation to be called on this new buffer. -Ignoring the rare case of a full buffer-range, the execution cost of a -'Builder' consists of three parts: - - 1. The time taken to read the parameters; i.e., the buffer-fill - operation to call after the 'Builder' is done and the buffer-range to - fill. - - 2. The time taken to check for the size of the buffer-range. - - 3. The time taken for the actual encoding. - -We can reduce cost (1) by ensuring that fewer buffer-fill function calls are -required. We can reduce cost (2) by fusing buffer-size checks of sequential -writes. For example, when escaping a 'String' using 'renderString', it would -be sufficient to check before encoding a character that at least 8 bytes are -free. We can reduce cost (3) by implementing better primitive 'Builder's. -For example, 'renderCell' builds an intermediate list containing the decimal -representation of an 'Int'. Implementing a direct decimal encoding of 'Int's -to memory would be more efficient, as it requires fewer buffer-size checks -and less allocation. It is also a planned extension of this library. - -The first two cost reductions are supported for user code through functions -in "Data.ByteString.Lazy.Builder.Extras". There, we continue the above example -and drop the generation time to 0.8ms by implementing 'renderString' more -cleverly. The third reduction requires meddling with the internals of -'Builder's and is not recomended in code outside of this library. However, -patches to this library are very welcome. --} -module Data.ByteString.Lazy.Builder.BasicEncoding ( - - -- * Fixed-size encodings - FixedEncoding - - -- ** Combinators - -- | The combinators for 'FixedEncoding's are implemented such that the 'size' - -- of the resulting 'FixedEncoding' is computed at compile time. - , emptyF - , pairF - , contramapF - - -- ** Builder construction - -- | In terms of expressivity, the function 'encodeWithF' would be sufficient - -- for constructing 'Builder's from 'FixedEncoding's. The fused variants of - -- this function are provided because they allow for more efficient - -- implementations. Our compilers are just not smart enough yet; and for some - -- of the employed optimizations (see the code of 'encodeByteStringWithF') - -- they will very likely never be. - -- - -- Note that functions marked with \"/Heavy inlining./\" are forced to be - -- inlined because they must be specialized for concrete encodings, - -- but are rather heavy in terms of code size. We recommend to define a - -- top-level function for every concrete instantiation of such a function in - -- order to share its code. A typical example is the function - -- 'byteStringHexFixed' from "Data.ByteString.Lazy.Builder.ASCII", which is - -- implemented as follows. - -- - -- @ - -- byteStringHexFixed :: S.ByteString -> Builder - -- byteStringHexFixed = 'encodeByteStringWithF' 'word8HexFixed' - -- @ - -- - , encodeWithF - , encodeListWithF - , encodeUnfoldrWithF - - , encodeByteStringWithF - , encodeLazyByteStringWithF - - -- * Bounded-size encodings - - , BoundedEncoding - - -- ** Combinators - -- | The combinators for 'BoundedEncoding's are implemented such that the - -- 'sizeBound' of the resulting 'BoundedEncoding' is computed at compile time. - , fromF - , emptyB - , pairB - , eitherB - , ifB - , contramapB - - -- | We provide overloaded operators for some of the above combinators to - -- allow for a more convenient syntax. We do not export their corresponding, - -- as we they are used for overloading only and should not be extended by - -- the user of this library. We plan to use the @contravariant@ library - -- once it is part of the - -- Haskell platform. - , (>*<) - , (>$<) - - -- ** Builder construction - , encodeWithB - , encodeListWithB - , encodeUnfoldrWithB - - , encodeByteStringWithB - , encodeLazyByteStringWithB - - -- * Standard encodings of Haskell values - - , module Data.ByteString.Lazy.Builder.BasicEncoding.Binary - - -- ** Character encodings - , module Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - - -- *** ISO/IEC 8859-1 (Char8) - -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. - -- The /Char8/ encoding implemented here works by truncating the Unicode - -- codepoint to 8-bits and encoding them as a single byte. For the codepoints - -- 0-255 this corresponds to the ISO/IEC 8859-1 encoding. Note that the - -- Char8 encoding is equivalent to the ASCII encoding on the Unicode - -- codepoints 0-127. Hence, functions such as 'intDec' can also be used for - -- encoding 'Int's as a decimal number with Char8 encoded characters. - , char8 - - -- *** UTF-8 - -- | The UTF-8 encoding can encode all Unicode codepoints. - -- It is equivalent to the ASCII encoding on the Unicode codepoints 0-127. - -- Hence, functions such as 'intDec' can also be used for encoding 'Int's as - -- a decimal number with UTF-8 encoded characters. - , charUtf8 - - -- * Testing support - -- | The following four functions are intended for testing use - -- only. They are /not/ efficient. Basic encodings are efficently executed by - -- creating 'Builder's from them using the @encodeXXX@ functions explained at - -- the top of this module. - - , evalF - , evalB - - , showF - , showB - - ) where - -import Data.ByteString.Lazy.Builder.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 (lowerTable, encode4_as_8) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - -import Data.Monoid -import Data.List (unfoldr) -- HADDOCK ONLY -import Data.Char (chr, ord) -import Control.Monad ((<=<), unless) - -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal hiding (size, sizeBound) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I (size, sizeBound) -import Data.ByteString.Lazy.Builder.BasicEncoding.Binary -import Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - ------------------------------------------------------------------------------- --- Creating Builders from bounded encodings ------------------------------------------------------------------------------- - --- | Encode a value with a 'FixedEncoding'. -{-# INLINE encodeWithF #-} -encodeWithF :: FixedEncoding a -> (a -> Builder) -encodeWithF = encodeWithB . toB - --- | Encode a list of values from left-to-right with a 'FixedEncoding'. -{-# INLINE encodeListWithF #-} -encodeListWithF :: FixedEncoding a -> ([a] -> Builder) -encodeListWithF = encodeListWithB . toB - --- | Encode a list of values represented as an 'unfoldr' with a 'FixedEncoding'. -{-# INLINE encodeUnfoldrWithF #-} -encodeUnfoldrWithF :: FixedEncoding b -> (a -> Maybe (b, a)) -> a -> Builder -encodeUnfoldrWithF = encodeUnfoldrWithB . toB - --- | /Heavy inlining./ Encode all bytes of a strict 'S.ByteString' from --- left-to-right with a 'FixedEncoding'. This function is quite versatile. For --- example, we can use it to construct a 'Builder' that maps every byte before --- copying it to the buffer to be filled. --- --- > mapToBuilder :: (Word8 -> Word8) -> S.ByteString -> Builder --- > mapToBuilder f = encodeByteStringWithF (contramapF f word8) --- --- We can also use it to hex-encode a strict 'S.ByteString' as shown by the --- 'byteStringHexFixed' example above. -{-# INLINE encodeByteStringWithF #-} -encodeByteStringWithF :: FixedEncoding Word8 -> (S.ByteString -> Builder) -encodeByteStringWithF = encodeByteStringWithB . toB - --- | /Heavy inlining./ Encode all bytes of a lazy 'L.ByteString' from --- left-to-right with a 'FixedEncoding'. -{-# INLINE encodeLazyByteStringWithF #-} -encodeLazyByteStringWithF :: FixedEncoding Word8 -> (L.ByteString -> Builder) -encodeLazyByteStringWithF = encodeLazyByteStringWithB . toB - --- IMPLEMENTATION NOTE: Sadly, 'encodeListWith' cannot be used for foldr/build --- fusion. Its performance relies on hoisting several variables out of the --- inner loop. That's not possible when writing 'encodeListWith' as a 'foldr'. --- If we had stream fusion for lists, then we could fuse 'encodeListWith', as --- 'encodeWithStream' can keep control over the execution. - - --- | Create a 'Builder' that encodes values with the given 'Encoding'. --- --- We rewrite consecutive uses of 'encodeWith' such that the bound-checks are --- fused. For example, --- --- > encodeWithB (word32 c1) `mappend` encodeWithB (word32 c2) --- --- is rewritten such that the resulting 'Builder' checks only once, if ther are --- at 8 free bytes, instead of checking twice, if there are 4 free bytes. This --- optimization is not observationally equivalent in a strict sense, as it --- influences the boundaries of the generated chunks. However, for a user of --- this library it is observationally equivalent, as chunk boundaries of a lazy --- 'L.ByteString' can only be observed through the internal interface. --- Morevoer, we expect that all 'Encoding's write much fewer than 4kb (the --- default short buffer size). Hence, it is safe to ignore the additional --- memory spilled due to the more agressive buffer wrapping introduced by this --- optimization. --- -{-# INLINE[1] encodeWithB #-} -encodeWithB :: BoundedEncoding a -> (a -> Builder) -encodeWithB w = - mkBuilder - where - bound = I.sizeBound w - mkBuilder x = builder step - where - step k (BufferRange op ope) - | op `plusPtr` bound <= ope = do - op' <- runB w x op - let !br' = BufferRange op' ope - k br' - | otherwise = return $ bufferFull bound op (step k) - -{-# RULES - -"append/encodeWithB" forall w1 w2 x1 x2. - append (encodeWithB w1 x1) (encodeWithB w2 x2) - = encodeWithB (pairB w1 w2) (x1, x2) - -"append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b. - append (encodeWithB w1 x1) (append (encodeWithB w2 x2) b) - = append (encodeWithB (pairB w1 w2) (x1, x2)) b - -"append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b. - append (append b (encodeWithB w1 x1)) (encodeWithB w2 x2) - = append b (encodeWithB (pairB w1 w2) (x1, x2)) - #-} - --- TODO: The same rules for 'putBuilder (..) >> putBuilder (..)' - --- | Create a 'Builder' that encodes a list of values consecutively using an --- 'Encoding'. This function is more efficient than the canonical --- --- > filter p = --- > B.toLazyByteString . --- > E.encodeLazyByteStringWithF (E.ifF p E.word8) E.emptyF) --- > --- --- > mconcat . map (encodeWithB w) --- --- or --- --- > foldMap (encodeWithB w) --- --- because it moves several variables out of the inner loop. -{-# INLINE encodeListWithB #-} -encodeListWithB :: BoundedEncoding a -> [a] -> Builder -encodeListWithB w = - makeBuilder - where - bound = I.sizeBound w - makeBuilder xs0 = builder $ step xs0 - where - step xs1 k !(BufferRange op0 ope0) = go xs1 op0 - where - go [] !op = do - let !br' = BufferRange op ope0 - k br' - - go xs@(x':xs') !op - | op `plusPtr` bound <= ope0 = do - !op' <- runB w x' op - go xs' op' - | otherwise = return $ bufferFull bound op (step xs k) - --- TODO: Add 'foldMap/encodeWith' its variants --- TODO: Ensure rewriting 'encodeWithB w . f = encodeWithB (w #. f)' - --- | Create a 'Builder' that encodes a sequence generated from a seed value --- using an 'Encoding'. -{-# INLINE encodeUnfoldrWithB #-} -encodeUnfoldrWithB :: BoundedEncoding b -> (a -> Maybe (b, a)) -> a -> Builder -encodeUnfoldrWithB w = - makeBuilder - where - bound = I.sizeBound w - makeBuilder f x0 = builder $ step x0 - where - step x1 !k = fill x1 - where - fill x !(BufferRange pf0 pe0) = go (f x) pf0 - where - go !Nothing !pf = do - let !br' = BufferRange pf pe0 - k br' - go !(Just (y, x')) !pf - | pf `plusPtr` bound <= pe0 = do - !pf' <- runB w y pf - go (f x') pf' - | otherwise = return $ bufferFull bound pf $ - \(BufferRange pfNew peNew) -> do - !pfNew' <- runB w y pfNew - fill x' (BufferRange pfNew' peNew) - --- | Create a 'Builder' that encodes each 'Word8' of a strict 'S.ByteString' --- using an 'Encoding'. For example, we can write a 'Builder' that filters --- a strict 'S.ByteString' as follows. --- --- > import Codec.Bounded.Encoding as E (encodeIf, word8, encodeNothing) --- --- > filterBS p = E.encodeIf p E.word8 E.encodeNothing --- -{-# INLINE encodeByteStringWithB #-} -encodeByteStringWithB :: BoundedEncoding Word8 -> S.ByteString -> Builder -encodeByteStringWithB w = - \bs -> builder $ step bs - where - bound = I.sizeBound w - step (S.PS ifp ioff isize) !k = - goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) - where - !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) - goBS !ip0 !br@(BufferRange op0 ope) - | ip0 >= ipe = do - touchForeignPtr ifp -- input buffer consumed - k br - - | op0 `plusPtr` bound < ope = - goPartial (ip0 `plusPtr` min outRemaining inpRemaining) - - | otherwise = return $ bufferFull bound op0 (goBS ip0) - where - outRemaining = (ope `minusPtr` op0) `div` bound - inpRemaining = ipe `minusPtr` ip0 - - goPartial !ipeTmp = go ip0 op0 - where - go !ip !op - | ip < ipeTmp = do - x <- peek ip - op' <- runB w x op - go (ip `plusPtr` 1) op' - | otherwise = - goBS ip (BufferRange op ope) - --- | Chunk-wise application of 'encodeByteStringWith'. -{-# INLINE encodeLazyByteStringWithB #-} -encodeLazyByteStringWithB :: BoundedEncoding Word8 -> L.ByteString -> Builder -encodeLazyByteStringWithB w = - L.foldrChunks (\x b -> encodeByteStringWithB w x `mappend` b) mempty - - ------------------------------------------------------------------------------- --- Char8 encoding ------------------------------------------------------------------------------- - --- | Char8 encode a 'Char'. -{-# INLINE char8 #-} -char8 :: FixedEncoding Char -char8 = (fromIntegral . ord) >$< word8 - - ------------------------------------------------------------------------------- --- UTF-8 encoding ------------------------------------------------------------------------------- - --- | UTF-8 encode a 'Char'. -{-# INLINE charUtf8 #-} -charUtf8 :: BoundedEncoding Char -charUtf8 = boundedEncoding 4 (encodeCharUtf8 f1 f2 f3 f4) - where - pokeN n io op = io op >> return (op `plusPtr` n) - - f1 x1 = pokeN 1 $ \op -> do pokeByteOff op 0 x1 - - f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - - f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - pokeByteOff op 2 x3 - - f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - pokeByteOff op 2 x3 - pokeByteOff op 3 x4 - --- | Encode a Unicode character to another datatype, using UTF-8. This function --- acts as an abstract way of encoding characters, as it is unaware of what --- needs to happen with the resulting bytes: you have to specify functions to --- deal with those. --- -{-# INLINE encodeCharUtf8 #-} -encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 - -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 - -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 - -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 - -> Char -- ^ Input 'Char' - -> a -- ^ Result -encodeCharUtf8 f1 f2 f3 f4 c = case ord c of - x | x <= 0x7F -> f1 $ fromIntegral x - | x <= 0x07FF -> - let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 - x2 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f2 x1 x2 - | x <= 0xFFFF -> - let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 - x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 - x3 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f3 x1 x2 x3 - | otherwise -> - let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 - x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 - x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 - x4 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f4 x1 x2 x3 x4 - - ------------------------------------------------------------------------------- --- Testing encodings ------------------------------------------------------------------------------- - --- | /For testing use only./ Evaluate a 'FixedEncoding' on a given value. -evalF :: FixedEncoding a -> a -> [Word8] -evalF fe = S.unpack . S.unsafeCreate (I.size fe) . runF fe - --- | /For testing use only./ Evaluate a 'BoundedEncoding' on a given value. -evalB :: BoundedEncoding a -> a -> [Word8] -evalB be x = S.unpack $ unsafePerformIO $ - S.createAndTrim (I.sizeBound be) $ \op -> do - op' <- runB be x op - return (op' `minusPtr` op) - --- | /For testing use only./ Show the result of a 'FixedEncoding' of a given --- value as a 'String' by interpreting the resulting bytes as Unicode --- codepoints. -showF :: FixedEncoding a -> a -> String -showF fe = map (chr . fromIntegral) . evalF fe - --- | /For testing use only./ Show the result of a 'BoundedEncoding' of a given --- value as a 'String' by interpreting the resulting bytes as Unicode --- codepoints. -showB :: BoundedEncoding a -> a -> String -showB be = map (chr . fromIntegral) . evalB be - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} --- | Copyright : (c) 2010 Jasper Van der Jeugt --- (c) 2010 - 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Encodings using ASCII encoded Unicode characters. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - ( - - -- *** ASCII - char7 - - -- **** Decimal numbers - -- | Decimal encoding of numbers using ASCII encoded characters. - , int8Dec - , int16Dec - , int32Dec - , int64Dec - , intDec - - , word8Dec - , word16Dec - , word32Dec - , word64Dec - , wordDec - - {- - -- These are the functions currently provided by Bryan O'Sullivans - -- double-conversion library. - -- - -- , float - -- , floatWith - -- , double - -- , doubleWith - -} - - -- **** Hexadecimal numbers - - -- | Encoding positive integers as hexadecimal numbers using lower-case - -- ASCII characters. The shortest possible representation is used. For - -- example, - -- - -- > showB word16Hex 0x0a10 = "a10" - -- - -- Note that there is no support for using upper-case characters. Please - -- contact the maintainer if your application cannot work without - -- hexadecimal encodings that use upper-case characters. - -- - , word8Hex - , word16Hex - , word32Hex - , word64Hex - , wordHex - - -- **** Fixed-width hexadecimal numbers - -- - -- | Encoding the bytes of fixed-width types as hexadecimal - -- numbers using lower-case ASCII characters. For example, - -- - -- > showF word16HexFixed 0x0a10 = "0a10" - -- - , int8HexFixed - , int16HexFixed - , int32HexFixed - , int64HexFixed - , word8HexFixed - , word16HexFixed - , word32HexFixed - , word64HexFixed - , floatHexFixed - , doubleHexFixed - - ) where - -import Data.ByteString.Lazy.Builder.BasicEncoding.Binary -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts - -import Data.Char (ord) - -import Foreign -import Foreign.C.Types - --- | Encode the least 7-bits of a 'Char' using the ASCII encoding. -{-# INLINE char7 #-} -char7 :: FixedEncoding Char -char7 = (\c -> fromIntegral $ ord c .&. 0x7f) >$< word8 - - ------------------------------------------------------------------------------- --- Decimal Encoding ------------------------------------------------------------------------------- - --- Signed integers ------------------- - -foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec - :: CInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec - :: CLLong -> Ptr Word8 -> IO (Ptr Word8) - -{-# INLINE encodeIntDecimal #-} -encodeIntDecimal :: Integral a => Int -> BoundedEncoding a -encodeIntDecimal bound = boundedEncoding bound $ c_int_dec . fromIntegral - --- | Decimal encoding of an 'Int8'. -{-# INLINE int8Dec #-} -int8Dec :: BoundedEncoding Int8 -int8Dec = encodeIntDecimal 4 - --- | Decimal encoding of an 'Int16'. -{-# INLINE int16Dec #-} -int16Dec :: BoundedEncoding Int16 -int16Dec = encodeIntDecimal 6 - - --- | Decimal encoding of an 'Int32'. -{-# INLINE int32Dec #-} -int32Dec :: BoundedEncoding Int32 -int32Dec = encodeIntDecimal 11 - --- | Decimal encoding of an 'Int64'. -{-# INLINE int64Dec #-} -int64Dec :: BoundedEncoding Int64 -int64Dec = boundedEncoding 20 $ c_long_long_int_dec . fromIntegral - --- | Decimal encoding of an 'Int'. -{-# INLINE intDec #-} -intDec :: BoundedEncoding Int -intDec = caseWordSize_32_64 - (fromIntegral >$< int32Dec) - (fromIntegral >$< int64Dec) - - --- Unsigned integers --------------------- - -foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec - :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec - :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - -{-# INLINE encodeWordDecimal #-} -encodeWordDecimal :: Integral a => Int -> BoundedEncoding a -encodeWordDecimal bound = boundedEncoding bound $ c_uint_dec . fromIntegral - --- | Decimal encoding of a 'Word8'. -{-# INLINE word8Dec #-} -word8Dec :: BoundedEncoding Word8 -word8Dec = encodeWordDecimal 3 - --- | Decimal encoding of a 'Word16'. -{-# INLINE word16Dec #-} -word16Dec :: BoundedEncoding Word16 -word16Dec = encodeWordDecimal 5 - --- | Decimal encoding of a 'Word32'. -{-# INLINE word32Dec #-} -word32Dec :: BoundedEncoding Word32 -word32Dec = encodeWordDecimal 10 - --- | Decimal encoding of a 'Word64'. -{-# INLINE word64Dec #-} -word64Dec :: BoundedEncoding Word64 -word64Dec = boundedEncoding 20 $ c_long_long_uint_dec . fromIntegral - --- | Decimal encoding of a 'Word'. -{-# INLINE wordDec #-} -wordDec :: BoundedEncoding Word -wordDec = caseWordSize_32_64 - (fromIntegral >$< word32Dec) - (fromIntegral >$< word64Dec) - ------------------------------------------------------------------------------- --- Hexadecimal Encoding ------------------------------------------------------------------------------- - --- without lead ---------------- - -foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex - :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex - :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - -{-# INLINE encodeWordHex #-} -encodeWordHex :: forall a. (Storable a, Integral a) => BoundedEncoding a -encodeWordHex = - boundedEncoding (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral - --- | Hexadecimal encoding of a 'Word8'. -{-# INLINE word8Hex #-} -word8Hex :: BoundedEncoding Word8 -word8Hex = encodeWordHex - --- | Hexadecimal encoding of a 'Word16'. -{-# INLINE word16Hex #-} -word16Hex :: BoundedEncoding Word16 -word16Hex = encodeWordHex - --- | Hexadecimal encoding of a 'Word32'. -{-# INLINE word32Hex #-} -word32Hex :: BoundedEncoding Word32 -word32Hex = encodeWordHex - --- | Hexadecimal encoding of a 'Word64'. -{-# INLINE word64Hex #-} -word64Hex :: BoundedEncoding Word64 -word64Hex = boundedEncoding 16 $ c_long_long_uint_hex . fromIntegral - --- | Hexadecimal encoding of a 'Word'. -{-# INLINE wordHex #-} -wordHex :: BoundedEncoding Word -wordHex = caseWordSize_32_64 - (fromIntegral >$< word32Hex) - (fromIntegral >$< word64Hex) - - --- fixed width; leading zeroes ------------------------------- - --- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). -{-# INLINE word8HexFixed #-} -word8HexFixed :: FixedEncoding Word8 -word8HexFixed = fixedEncoding 2 $ - \x op -> poke (castPtr op) =<< encode8_as_16h lowerTable x - --- | Encode a 'Word16' using 4 nibbles. -{-# INLINE word16HexFixed #-} -word16HexFixed :: FixedEncoding Word16 -word16HexFixed = - (\x -> (fromIntegral $ x `shiftr_w16` 8, fromIntegral x)) - >$< pairF word8HexFixed word8HexFixed - --- | Encode a 'Word32' using 8 nibbles. -{-# INLINE word32HexFixed #-} -word32HexFixed :: FixedEncoding Word32 -word32HexFixed = - (\x -> (fromIntegral $ x `shiftr_w32` 16, fromIntegral x)) - >$< pairF word16HexFixed word16HexFixed --- | Encode a 'Word64' using 16 nibbles. -{-# INLINE word64HexFixed #-} -word64HexFixed :: FixedEncoding Word64 -word64HexFixed = - (\x -> (fromIntegral $ x `shiftr_w64` 32, fromIntegral x)) - >$< pairF word32HexFixed word32HexFixed - --- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). -{-# INLINE int8HexFixed #-} -int8HexFixed :: FixedEncoding Int8 -int8HexFixed = fromIntegral >$< word8HexFixed - --- | Encode a 'Int16' using 4 nibbles. -{-# INLINE int16HexFixed #-} -int16HexFixed :: FixedEncoding Int16 -int16HexFixed = fromIntegral >$< word16HexFixed - --- | Encode a 'Int32' using 8 nibbles. -{-# INLINE int32HexFixed #-} -int32HexFixed :: FixedEncoding Int32 -int32HexFixed = fromIntegral >$< word32HexFixed - --- | Encode a 'Int64' using 16 nibbles. -{-# INLINE int64HexFixed #-} -int64HexFixed :: FixedEncoding Int64 -int64HexFixed = fromIntegral >$< word64HexFixed - --- | Encode an IEEE 'Float' using 8 nibbles. -{-# INLINE floatHexFixed #-} -floatHexFixed :: FixedEncoding Float -floatHexFixed = encodeFloatViaWord32F word32HexFixed - --- | Encode an IEEE 'Double' using 16 nibbles. -{-# INLINE doubleHexFixed #-} -doubleHexFixed :: FixedEncoding Double -doubleHexFixed = encodeDoubleViaWord64F word64HexFixed - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} --- | Copyright : (c) 2010-2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Binary ( - - -- ** Binary encodings - int8 - , word8 - - -- *** Big-endian - , int16BE - , int32BE - , int64BE - - , word16BE - , word32BE - , word64BE - - , floatBE - , doubleBE - - -- *** Little-endian - , int16LE - , int32LE - , int64LE - - , word16LE - , word32LE - , word64LE - - , floatLE - , doubleLE - - -- *** Non-portable, host-dependent - , intHost - , int16Host - , int32Host - , int64Host - - , wordHost - , word16Host - , word32Host - , word64Host - - , floatHost - , doubleHost - - ) where - -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating - -import Foreign - -#include "MachDeps.h" - ------------------------------------------------------------------------------- --- Binary encoding ------------------------------------------------------------------------------- - --- Word encodings ------------------ - --- | Encoding single unsigned bytes as-is. --- -{-# INLINE word8 #-} -word8 :: FixedEncoding Word8 -word8 = storableToF - --- --- We rely on the fromIntegral to do the right masking for us. --- The inlining here is critical, and can be worth 4x performance --- - --- | Encoding 'Word16's in big endian format. -{-# INLINE word16BE #-} -word16BE :: FixedEncoding Word16 -#ifdef WORD_BIGENDIAN -word16BE = word16Host -#else -word16BE = fixedEncoding 2 $ \w p -> do - poke p (fromIntegral (shiftr_w16 w 8) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) -#endif - --- | Encoding 'Word16's in little endian format. -{-# INLINE word16LE #-} -word16LE :: FixedEncoding Word16 -#ifdef WORD_BIGENDIAN -word16LE = fixedEncoding 2 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) -#else -word16LE = word16Host -#endif - --- | Encoding 'Word32's in big endian format. -{-# INLINE word32BE #-} -word32BE :: FixedEncoding Word32 -#ifdef WORD_BIGENDIAN -word32BE = word32Host -#else -word32BE = fixedEncoding 4 $ \w p -> do - poke p (fromIntegral (shiftr_w32 w 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) -#endif - --- | Encoding 'Word32's in little endian format. -{-# INLINE word32LE #-} -word32LE :: FixedEncoding Word32 -#ifdef WORD_BIGENDIAN -word32LE = fixedEncoding 4 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) -#else -word32LE = word32Host -#endif - --- on a little endian machine: --- word32LE w32 = fixedEncoding 4 (\w p -> poke (castPtr p) w32) - --- | Encoding 'Word64's in big endian format. -{-# INLINE word64BE #-} -word64BE :: FixedEncoding Word64 -#ifdef WORD_BIGENDIAN -word64BE = word64Host -#else -#if WORD_SIZE_IN_BITS < 64 --- --- To avoid expensive 64 bit shifts on 32 bit machines, we cast to --- Word32, and write that --- -word64BE = - fixedEncoding 8 $ \w p -> do - let a = fromIntegral (shiftr_w64 w 32) :: Word32 - b = fromIntegral w :: Word32 - poke p (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) -#else -word64BE = fixedEncoding 8 $ \w p -> do - poke p (fromIntegral (shiftr_w64 w 56) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) -#endif -#endif - --- | Encoding 'Word64's in little endian format. -{-# INLINE word64LE #-} -word64LE :: FixedEncoding Word64 -#ifdef WORD_BIGENDIAN -#if WORD_SIZE_IN_BITS < 64 -word64LE = - fixedEncoding 8 $ \w p -> do - let b = fromIntegral (shiftr_w64 w 32) :: Word32 - a = fromIntegral w :: Word32 - poke (p) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) -#else -word64LE = fixedEncoding 8 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) -#endif -#else -word64LE = word64Host -#endif - - --- | Encode a single native machine 'Word'. The 'Word's is encoded in host order, --- host endian form, for the machine you are on. On a 64 bit machine the 'Word' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or word sized machines, without --- conversion. --- -{-# INLINE wordHost #-} -wordHost :: FixedEncoding Word -wordHost = storableToF - --- | Encoding 'Word16's in native host order and host endianness. -{-# INLINE word16Host #-} -word16Host :: FixedEncoding Word16 -word16Host = storableToF - --- | Encoding 'Word32's in native host order and host endianness. -{-# INLINE word32Host #-} -word32Host :: FixedEncoding Word32 -word32Host = storableToF - --- | Encoding 'Word64's in native host order and host endianness. -{-# INLINE word64Host #-} -word64Host :: FixedEncoding Word64 -word64Host = storableToF - - ------------------------------------------------------------------------------- --- Int encodings ------------------------------------------------------------------------------- --- --- We rely on 'fromIntegral' to do a loss-less conversion to the corresponding --- 'Word' type --- ------------------------------------------------------------------------------- - --- | Encoding single signed bytes as-is. --- -{-# INLINE int8 #-} -int8 :: FixedEncoding Int8 -int8 = fromIntegral >$< word8 - --- | Encoding 'Int16's in big endian format. -{-# INLINE int16BE #-} -int16BE :: FixedEncoding Int16 -int16BE = fromIntegral >$< word16BE - --- | Encoding 'Int16's in little endian format. -{-# INLINE int16LE #-} -int16LE :: FixedEncoding Int16 -int16LE = fromIntegral >$< word16LE - --- | Encoding 'Int32's in big endian format. -{-# INLINE int32BE #-} -int32BE :: FixedEncoding Int32 -int32BE = fromIntegral >$< word32BE - --- | Encoding 'Int32's in little endian format. -{-# INLINE int32LE #-} -int32LE :: FixedEncoding Int32 -int32LE = fromIntegral >$< word32LE - --- | Encoding 'Int64's in big endian format. -{-# INLINE int64BE #-} -int64BE :: FixedEncoding Int64 -int64BE = fromIntegral >$< word64BE - --- | Encoding 'Int64's in little endian format. -{-# INLINE int64LE #-} -int64LE :: FixedEncoding Int64 -int64LE = fromIntegral >$< word64LE - - --- TODO: Ensure that they are safe on architectures where an unaligned write is --- an error. - --- | Encode a single native machine 'Int'. The 'Int's is encoded in host order, --- host endian form, for the machine you are on. On a 64 bit machine the 'Int' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or integer sized machines, without --- conversion. --- -{-# INLINE intHost #-} -intHost :: FixedEncoding Int -intHost = storableToF - --- | Encoding 'Int16's in native host order and host endianness. -{-# INLINE int16Host #-} -int16Host :: FixedEncoding Int16 -int16Host = storableToF - --- | Encoding 'Int32's in native host order and host endianness. -{-# INLINE int32Host #-} -int32Host :: FixedEncoding Int32 -int32Host = storableToF - --- | Encoding 'Int64's in native host order and host endianness. -{-# INLINE int64Host #-} -int64Host :: FixedEncoding Int64 -int64Host = storableToF - --- IEEE Floating Point Numbers ------------------------------- - --- | Encode a 'Float' in big endian format. -{-# INLINE floatBE #-} -floatBE :: FixedEncoding Float -floatBE = encodeFloatViaWord32F word32BE - --- | Encode a 'Float' in little endian format. -{-# INLINE floatLE #-} -floatLE :: FixedEncoding Float -floatLE = encodeFloatViaWord32F word32LE - --- | Encode a 'Double' in big endian format. -{-# INLINE doubleBE #-} -doubleBE :: FixedEncoding Double -doubleBE = encodeDoubleViaWord64F word64BE - --- | Encode a 'Double' in little endian format. -{-# INLINE doubleLE #-} -doubleLE :: FixedEncoding Double -doubleLE = encodeDoubleViaWord64F word64LE - - --- | Encode a 'Float' in native host order and host endianness. Values written --- this way are not portable to different endian machines, without conversion. --- -{-# INLINE floatHost #-} -floatHost :: FixedEncoding Float -floatHost = storableToF - --- | Encode a 'Double' in native host order and host endianness. -{-# INLINE doubleHost #-} -doubleHost :: FixedEncoding Double -doubleHost = storableToF - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs +++ /dev/null @@ -1,890 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_HADDOCK hide #-} -{- | Copyright : (c) 2010-2011 Simon Meier -License : BSD3-style (see LICENSE) - -Maintainer : Simon Meier -Stability : experimental -Portability : GHC - -An /encoding/ is a conversion function of Haskell values to sequences of bytes. -A /fixed(-size) encoding/ is an encoding that always results in sequence of bytes - of a pre-determined, fixed length. -An example for a fixed encoding is the big-endian encoding of a 'Word64', - which always results in exactly 8 bytes. -A /bounded(-size) encoding/ is an encoding that always results in sequence - of bytes that is no larger than a pre-determined bound. -An example for a bounded encoding is the UTF-8 encoding of a 'Char', - which results always in less or equal to 4 bytes. -Note that every fixed encoding is also a bounded encoding. -We explicitly identify fixed encodings because they allow some optimizations - that are impossible with bounded encodings. -In the following, - we first motivate the use of bounded encodings - and then give examples of optimizations - that are only possible with fixed encodings. - -Typicall, encodings are implemented efficiently by allocating a buffer - (a mutable array of bytes) - and repeatedly executing the following two steps: - (1) writing to the buffer until it is full and - (2) handing over the filled part to the consumer of the encoded value. -Step (1) is where bounded encodings are used. -We must use a bounded encoding, - as we must check that there is enough free space - /before/ actually writing to the buffer. - -In term of expressivity, - it would be sufficient to construct all encodings - from the single fixed encoding that encodes a 'Word8' as-is. -However, - this is not sufficient in terms of efficiency. -It results in unnecessary buffer-full checks and - it complicates the program-flow for writing to the buffer, - as buffer-full checks are interleaved with analyzing the value to be - encoded (e.g., think about the program-flow for UTF-8 encoding). -This has a significant effect on overall encoding performance, - as encoding primitive Haskell values such as 'Word8's or 'Char's - lies at the heart of every encoding implementation. - -The 'BoundedEncoding's provided by this module remove this performance problem. -Intuitively, - they consist of a tuple of the bound on the maximal number of bytes written - and the actual implementation of the encoding as - a function that modifies a mutable buffer. -Hence when executing a 'BoundedEncoding', - the buffer-full check can be done once before the actual writing to the buffer. -The provided 'BoundedEncoding's also take care to implement the - actual writing to the buffer efficiently. -Moreover, combinators are provided to construct new bounded encodings - from the provided ones. - - - -The result of an encoding can be consumed efficiently, - if it is represented as a sequence of large enough - /chunks/ of consecutive memory (i.e., C @char@ arrays). -The precise meaning of /large enough/ is application dependent. -Typically, an average chunk size between 4kb and 32kb is suitable - for writing the result to disk or sending it over the network. -We desire large enough chunk sizes because each chunk boundary - incurs extra work that we must be able to amortize. - - -The need for fixed-size encodings arises when considering - the efficient implementation of encodings that require the encoding of a - value to be prefixed with the size of the resulting sequence of bytes. -An efficient implementation avoids unnecessary buffer -We can implement this efficiently as follows. -We first reserve the space for the encoding of the size. -Then, we encode the value. -Finally, we encode the size of the resulting sequence of bytes into - the reserved space. -For this to work - -This works only if the encoding resulting size fits - -by first, reserving the space for the encoding - of the size, then performing the - -For efficiency, - we want to avoid unnecessary copying. - - -For example, the HTTP/1.0 requires the size of the body to be given in - the Content-Length field. - -chunked-transfer encoding requires each chunk to - be prefixed with the hexadecimal encoding of the chunk size. - - --} - -{- --- --- --- A /bounded encoding/ is an encoding that never results in a sequence --- longer than some fixed number of bytes. This number of bytes must be --- independent of the value being encoded. Typical examples of bounded --- encodings are the big-endian encoding of a 'Word64', which results always --- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always --- in less or equal to 4 bytes. --- --- Typically, encodings are implemented efficiently by allocating a buffer (an --- array of bytes) and repeatedly executing the following two steps: (1) --- writing to the buffer until it is full and (2) handing over the filled part --- to the consumer of the encoded value. Step (1) is where bounded encodings --- are used. We must use a bounded encoding, as we must check that there is --- enough free space /before/ actually writing to the buffer. --- --- In term of expressivity, it would be sufficient to construct all encodings --- from the single bounded encoding that encodes a 'Word8' as-is. However, --- this is not sufficient in terms of efficiency. It results in unnecessary --- buffer-full checks and it complicates the program-flow for writing to the --- buffer, as buffer-full checks are interleaved with analyzing the value to be --- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a --- significant effect on overall encoding performance, as encoding primitive --- Haskell values such as 'Word8's or 'Char's lies at the heart of every --- encoding implementation. --- --- The bounded 'Encoding's provided by this module remove this performance --- problem. Intuitively, they consist of a tuple of the bound on the maximal --- number of bytes written and the actual implementation of the encoding as a --- function that modifies a mutable buffer. Hence when executing a bounded --- 'Encoding', the buffer-full check can be done once before the actual writing --- to the buffer. The provided 'Encoding's also take care to implement the --- actual writing to the buffer efficiently. Moreover, combinators are --- provided to construct new bounded encodings from the provided ones. --- --- A typical example for using the combinators is a bounded 'Encoding' that --- combines escaping the ' and \\ characters with UTF-8 encoding. More --- precisely, the escaping to be done is the one implemented by the following --- @escape@ function. --- --- > escape :: Char -> [Char] --- > escape '\'' = "\\'" --- > escape '\\' = "\\\\" --- > escape c = [c] --- --- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is --- the following. --- --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > {-# INLINE escapeChar #-} --- > escapeUtf8 :: BoundedEncoding Char --- > escapeUtf8 = --- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ --- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ --- > char --- --- The definition of 'escapeUtf8' is more complicated than 'escape', because --- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in --- 'escapeChar' compute both the bound on the maximal number of bytes written --- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required --- to implement the encoding. Bounded 'Encoding's should always be inlined. --- Otherwise, the compiler cannot compute the bound on the maximal number of --- bytes written at compile-time. Without inlinining, it would also fail to --- optimize the constant encoding of the escape characters in the above --- example. Functions that execute bounded 'Encoding's also perform --- suboptimally, if the definition of the bounded 'Encoding' is not inlined. --- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. --- --- Currently, the only library that executes bounded 'Encoding's is the --- 'bytestring' library (). It --- uses bounded 'Encoding's to implement most of its lazy bytestring builders. --- Executing a bounded encoding should be done using the corresponding --- functions in the lazy bytestring builder 'Extras' module. --- --- TODO: Merge with explanation/example below --- --- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by --- writing a bounded-size sequence of bytes directly to memory. They are --- lifted to conversions from Haskell values to 'Builder's by wrapping them --- with a bound-check. The compiler can implement this bound-check very --- efficiently (i.e, a single comparison of the difference of two pointers to a --- constant), because the bound of a 'E.Encoding' is always independent of the --- value being encoded and, in most cases, a literal constant. --- --- 'E.Encoding's are the primary means for defining conversion functions from --- primitive Haskell values to 'Builder's. Most 'Builder' constructors --- provided by this library are implemented that way. --- 'E.Encoding's are also used to construct conversions that exploit the internal --- representation of data-structures. --- --- For example, 'encodeByteStringWith' works directly on the underlying byte --- array and uses some tricks to reduce the number of variables in its inner --- loop. Its efficiency is exploited for implementing the @filter@ and @map@ --- functions in "Data.ByteString.Lazy" as --- --- > import qualified Codec.Bounded.Encoding as E --- > --- > filter :: (Word8 -> Bool) -> ByteString -> ByteString --- > filter p = toLazyByteString . encodeLazyByteStringWithB write --- > where --- > write = E.encodeIf p E.word8 E.emptyEncoding --- > --- > map :: (Word8 -> Word8) -> ByteString -> ByteString --- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) --- --- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, --- these versions use a more efficient inner loop and have the additional --- advantage that they always result in well-chunked 'L.ByteString's; i.e, they --- also perform automatic defragmentation. --- --- We can also use 'E.Encoding's to improve the efficiency of the following --- 'renderString' function from our UTF-8 CSV table encoding example in --- "Data.ByteString.Lazy.Builder". --- --- > renderString :: String -> Builder --- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' --- > where --- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' --- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' --- > escape c = charUtf8 c --- --- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes --- characters and using 'encodeListWith', which implements writing a list of --- values with a tighter inner loop and no 'mappend'. --- --- > import Data.ByteString.Lazy.Builder.Extras -- assume these three --- > import Codec.Bounded.Encoding -- imports are present --- > ( BoundedEncoding, encodeIf, (<#>), (#.) ) --- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) --- > --- > renderString :: String -> Builder --- > renderString cs = --- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' --- > where --- > escapedUtf8 :: BoundedEncoding Char --- > escapedUtf8 = --- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ --- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ --- > char --- --- This 'Builder' considers a buffer with less than 8 free bytes as full. As --- all functions are inlined, the compiler is able to optimize the constant --- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of --- 'renderString' this implementation is 1.7x faster. --- --} -{- -Internally, 'Builder's are buffer-fill operations that are -given a continuation buffer-fill operation and a buffer-range to be filled. -A 'Builder' first checks if the buffer-range is large enough. If that's -the case, the 'Builder' writes the sequences of bytes to the buffer and -calls its continuation. Otherwise, it returns a signal that it requires a -new buffer together with a continuation to be called on this new buffer. -Ignoring the rare case of a full buffer-range, the execution cost of a -'Builder' consists of three parts: - - 1. The time taken to read the parameters; i.e., the buffer-fill - operation to call after the 'Builder' is done and the buffer-range to - fill. - - 2. The time taken to check for the size of the buffer-range. - - 3. The time taken for the actual encoding. - -We can reduce cost (1) by ensuring that fewer buffer-fill function calls are -required. We can reduce cost (2) by fusing buffer-size checks of sequential -writes. For example, when escaping a 'String' using 'renderString', it would -be sufficient to check before encoding a character that at least 8 bytes are -free. We can reduce cost (3) by implementing better primitive 'Builder's. -For example, 'renderCell' builds an intermediate list containing the decimal -representation of an 'Int'. Implementing a direct decimal encoding of 'Int's -to memory would be more efficient, as it requires fewer buffer-size checks -and less allocation. It is also a planned extension of this library. - -The first two cost reductions are supported for user code through functions -in "Data.ByteString.Lazy.Builder.Extras". There, we continue the above example -and drop the generation time to 0.8ms by implementing 'renderString' more -cleverly. The third reduction requires meddling with the internals of -'Builder's and is not recomended in code outside of this library. However, -patches to this library are very welcome. --} -module Data.ByteString.Lazy.Builder.BasicEncoding.Extras ( - - -- * Base-128, variable-length binary encodings - {- | -There are many options for implementing a base-128 (i.e, 7-bit), -variable-length encoding. The encoding implemented here is the one used by -Google's protocol buffer library -. This -encoding can be implemented efficiently and provides the desired property that -small positive integers result in short sequences of bytes. It is intended to -be used for the new default binary serialization format of the differently -sized 'Word' types. It works as follows. - -The most-significant bit (MSB) of each output byte indicates whether -there is a following byte (MSB set to 1) or it is the last byte (MSB set to 0). -The remaining 7-bits are used to encode the input starting with the least -significant 7-bit group of the input (i.e., a little-endian ordering of the -7-bit groups is used). - -For example, the value @1 :: Int@ is encoded as @[0x01]@. The value -@128 :: Int@, whose binary representation is @1000 0000@, is encoded as -@[0x80, 0x01]@; i.e., the first byte has its MSB set and the least significant -7-bit group is @000 0000@, the second byte has its MSB not set (it is the last -byte) and its 7-bit group is @000 0001@. --} - word8Var - , word16Var - , word32Var - , word64Var - , wordVar - -{- | -The following encodings work by casting the signed integer to the equally sized -unsigned integer. This works well for positive integers, but for negative -integers it always results in the longest possible sequence of bytes, -as their MSB is (by definition) always set. --} - - , int8Var - , int16Var - , int32Var - , int64Var - , intVar - -{- | -Positive and negative integers of small magnitude can be encoded compactly - using the so-called ZigZag encoding - (). -The /ZigZag encoding/ uses - even numbers to encode the postive integers and - odd numbers to encode the negative integers. -For example, - @0@ is encoded as @0@, @-1@ as @1@, @1@ as @2@, @-2@ as @3@, @2@ as @4@, and - so on. -Its efficient implementation uses some bit-level magic. -For example - -@ -zigZag32 :: 'Int32' -> 'Word32' -zigZag32 n = fromIntegral ((n \`shiftL\` 1) \`xor\` (n \`shiftR\` 31)) -@ - -Note that the 'shiftR' is an arithmetic shift that performs sign extension. -The ZigZag encoding essentially swaps the LSB with the MSB and additionally -inverts all bits if the MSB is set. - -The following encodings implement the combintion of ZigZag encoding - together with the above base-128, variable length encodings. -They are intended to become the the new default binary serialization format of - the differently sized 'Int' types. --} - , int8VarSigned - , int16VarSigned - , int32VarSigned - , int64VarSigned - , intVarSigned - - - -- * Chunked / size-prefixed encodings -{- | -Some encodings like ASN.1 BER -or Google's protocol buffers require -encoded data to be prefixed with its length. The simple method to achieve this -is to encode the data first into a separate buffer, compute the length of the -encoded data, write it to the current output buffer, and append the separate -buffers. The drawback of this method is that it requires a ... --} - , size - , sizeBound - -- , withSizeFB - -- , withSizeBB - , encodeWithSize - - , encodeChunked - - , wordVarFixedBound - , wordHexFixedBound - , wordDecFixedBound - - , word64VarFixedBound - , word64HexFixedBound - , word64DecFixedBound - - ) where - -import Data.ByteString.Lazy.Builder.Internal -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 (lowerTable, encode4_as_8) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - -import Data.Monoid -import Data.List (unfoldr) -- HADDOCK ONLY -import Data.Char (chr, ord) -import Control.Monad ((<=<), unless) - -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal hiding (size, sizeBound) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I (size, sizeBound) -import Data.ByteString.Lazy.Builder.BasicEncoding.Binary -import Data.ByteString.Lazy.Builder.BasicEncoding.ASCII -import Data.ByteString.Lazy.Builder.BasicEncoding - -import Foreign - ------------------------------------------------------------------------------- --- Adapting 'size' for the public interface. ------------------------------------------------------------------------------- - --- | The size of the sequence of bytes generated by this 'FixedEncoding'. -size :: FixedEncoding a -> Word -size = fromIntegral . I.size - --- | The bound on the size of the sequence of bytes generated by this --- 'BoundedEncoding'. -sizeBound :: BoundedEncoding a -> Word -sizeBound = fromIntegral . I.sizeBound - - ------------------------------------------------------------------------------- --- Base-128 Variable-Length Encodings ------------------------------------------------------------------------------- - -{-# INLINE encodeBase128 #-} -encodeBase128 - :: forall a b. (Integral a, Bits a, Storable b, Integral b, Num b) - => (a -> Int -> a) -> BoundedEncoding b -encodeBase128 shiftr = - -- We add 6 because we require the result of (`div` 7) to be rounded up. - boundedEncoding ((8 * sizeOf (undefined :: b) + 6) `div` 7) (io . fromIntegral) - where - io !x !op - | x' == 0 = do poke8 (x .&. 0x7f) - return $! op `plusPtr` 1 - | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) - io x' (op `plusPtr` 1) - where - x' = x `shiftr` 7 - poke8 = poke op . fromIntegral - --- | Base-128, variable length encoding of a 'Word8'. -{-# INLINE word8Var #-} -word8Var :: BoundedEncoding Word8 -word8Var = encodeBase128 shiftr_w - --- | Base-128, variable length encoding of a 'Word16'. -{-# INLINE word16Var #-} -word16Var :: BoundedEncoding Word16 -word16Var = encodeBase128 shiftr_w - --- | Base-128, variable length encoding of a 'Word32'. -{-# INLINE word32Var #-} -word32Var :: BoundedEncoding Word32 -word32Var = encodeBase128 shiftr_w32 - --- | Base-128, variable length encoding of a 'Word64'. -{-# INLINE word64Var #-} -word64Var :: BoundedEncoding Word64 -word64Var = encodeBase128 shiftr_w64 - --- | Base-128, variable length encoding of a 'Word'. -{-# INLINE wordVar #-} -wordVar :: BoundedEncoding Word -wordVar = encodeBase128 shiftr_w - - --- | Base-128, variable length encoding of an 'Int8'. --- Use 'int8VarSigned' for encoding negative numbers. -{-# INLINE int8Var #-} -int8Var :: BoundedEncoding Int8 -int8Var = fromIntegral >$< word8Var - --- | Base-128, variable length encoding of an 'Int16'. --- Use 'int16VarSigned' for encoding negative numbers. -{-# INLINE int16Var #-} -int16Var :: BoundedEncoding Int16 -int16Var = fromIntegral >$< word16Var - --- | Base-128, variable length encoding of an 'Int32'. --- Use 'int32VarSigned' for encoding negative numbers. -{-# INLINE int32Var #-} -int32Var :: BoundedEncoding Int32 -int32Var = fromIntegral >$< word32Var - --- | Base-128, variable length encoding of an 'Int64'. --- Use 'int64VarSigned' for encoding negative numbers. -{-# INLINE int64Var #-} -int64Var :: BoundedEncoding Int64 -int64Var = fromIntegral >$< word64Var - --- | Base-128, variable length encoding of an 'Int'. --- Use 'intVarSigned' for encoding negative numbers. -{-# INLINE intVar #-} -intVar :: BoundedEncoding Int -intVar = fromIntegral >$< wordVar - -{-# INLINE zigZag #-} -zigZag :: (Storable a, Bits a) => a -> a -zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1)) - --- | Base-128, variable length, ZigZag encoding of an 'Int'. -{-# INLINE int8VarSigned #-} -int8VarSigned :: BoundedEncoding Int8 -int8VarSigned = zigZag >$< int8Var - --- | Base-128, variable length, ZigZag encoding of an 'Int16'. -{-# INLINE int16VarSigned #-} -int16VarSigned :: BoundedEncoding Int16 -int16VarSigned = zigZag >$< int16Var - --- | Base-128, variable length, ZigZag encoding of an 'Int32'. -{-# INLINE int32VarSigned #-} -int32VarSigned :: BoundedEncoding Int32 -int32VarSigned = zigZag >$< int32Var - --- | Base-128, variable length, ZigZag encoding of an 'Int64'. -{-# INLINE int64VarSigned #-} -int64VarSigned :: BoundedEncoding Int64 -int64VarSigned = zigZag >$< int64Var - --- | Base-128, variable length, ZigZag encoding of an 'Int'. -{-# INLINE intVarSigned #-} -intVarSigned :: BoundedEncoding Int -intVarSigned = zigZag >$< intVar - - - ------------------------------------------------------------------------------- --- Chunked Encoding Transformer ------------------------------------------------------------------------------- - --- | /Heavy inlining./ -{-# INLINE encodeChunked #-} -encodeChunked - :: Word -- ^ Minimal free-size - -> (Word64 -> FixedEncoding Word64) - -- ^ Given a sizeBound on the maximal encodable size this function must return - -- a fixed-size encoding for encoding all smaller size. - -> (BoundedEncoding Word64) - -- ^ An encoding for terminating a chunk of the given size. - -> Builder - -- ^ Inner Builder to transform - -> Builder - -- ^ 'Put' with chunked encoding. -encodeChunked minFree mkBeforeFE afterBE = - fromPut . putChunked minFree mkBeforeFE afterBE . putBuilder - --- | /Heavy inlining./ -{-# INLINE putChunked #-} -putChunked - :: Word -- ^ Minimal free-size - -> (Word64 -> FixedEncoding Word64) - -- ^ Given a sizeBound on the maximal encodable size this function must return - -- a fixed-size encoding for encoding all smaller size. - -> (BoundedEncoding Word64) - -- ^ Encoding a directly inserted chunk. - -> Put a - -- ^ Inner Put to transform - -> Put a - -- ^ 'Put' with chunked encoding. -putChunked minFree0 mkBeforeFE afterBE p = - put encodingStep - where - minFree, reservedAfter, maxReserved, minBufferSize :: Int - minFree = fromIntegral $ max 1 minFree0 -- sanitize and convert to Int - - -- reserved space must be computed for maximum buffer size to cover for all - -- sizes of the actually returned buffer. - reservedAfter = I.sizeBound afterBE - maxReserved = I.size (mkBeforeFE maxBound) + reservedAfter - minBufferSize = minFree + maxReserved - - encodingStep k = - fill (runPut p) - where - fill innerStep !(BufferRange op ope) - | outRemaining < minBufferSize = - return $! bufferFull minBufferSize op (fill innerStep) - | otherwise = do - fillWithBuildStep innerStep doneH fullH insertChunksH brInner - where - outRemaining = ope `minusPtr` op - beforeFE = mkBeforeFE $ fromIntegral outRemaining - reservedBefore = I.size beforeFE - - opInner = op `plusPtr` reservedBefore - opeInner = ope `plusPtr` (-reservedAfter) - brInner = BufferRange opInner opeInner - - wrapChunk :: Ptr Word8 -> IO (Ptr Word8) - wrapChunk !opInner' - | innerSize == 0 = return op -- no data written => no chunk to wrap - | otherwise = do - runF beforeFE innerSize op - runB afterBE innerSize opInner' - where - innerSize = fromIntegral $ opInner' `minusPtr` opInner - - doneH opInner' x = do - op' <- wrapChunk opInner' - let !br' = BufferRange op' ope - k x br' - - fullH opInner' minSize nextInnerStep = do - op' <- wrapChunk opInner' - return $! bufferFull - (max minBufferSize (minSize + maxReserved)) - op' - (fill nextInnerStep) - - insertChunksH opInner' n lbsC nextInnerStep - | n == 0 = do -- flush - op' <- wrapChunk opInner' - return $! insertChunks op' 0 id (fill nextInnerStep) - - | otherwise = do -- insert non-empty bytestring - op' <- wrapChunk opInner' - let !br' = BufferRange op' ope - runBuilderWith chunkB (fill nextInnerStep) br' - where - nU = fromIntegral n - chunkB = - encodeWithF (mkBeforeFE nU) nU `mappend` - lazyByteStringC n lbsC `mappend` - encodeWithB afterBE nU - - --- | /Heavy inlining./ Prefix a 'Builder' with the size of the --- sequence of bytes that it denotes. --- --- This function is optimized for streaming use. It tries to prefix the size --- without copying the output. This is achieved by reserving space for the --- maximum size to be encoded. This succeeds if the output is smaller than --- the current free buffer size, which is guaranteed to be at least @8kb@. --- --- If the output does not fit into the current free buffer size, --- the method falls back to encoding the data to a separate lazy bytestring, --- computing the size, and encoding the size before inserting the chunks of --- the separate lazy bytestring. -{-# INLINE encodeWithSize #-} -encodeWithSize - :: - Word - -- ^ Inner buffer-size. - -> (Word64 -> FixedEncoding Word64) - -- ^ Given a bound on the maximal size to encode, this function must return - -- a fixed-size encoding for all smaller sizes. - -> Builder - -- ^ 'Put' to prefix with the length of its sequence of bytes. - -> Builder -encodeWithSize innerBufSize mkSizeFE = - fromPut . putWithSize innerBufSize mkSizeFE . putBuilder - --- | Prefix a 'Put' with the size of its written data. -{-# INLINE putWithSize #-} -putWithSize - :: forall a. - Word - -- ^ Buffer-size for inner driver. - -> (Word64 -> FixedEncoding Word64) - -- ^ Encoding the size for the fallback case. - -> Put a - -- ^ 'Put' to prefix with the length of its sequence of bytes. - -> Put a -putWithSize innerBufSize mkSizeFE innerP = - put $ encodingStep - where - -- | The minimal free size is such that we can encode any size. - minFree = I.size $ mkSizeFE maxBound - - encodingStep :: (forall r. (a -> BuildStep r) -> BuildStep r) - encodingStep k = - fill (runPut innerP) - where - fill :: BuildStep a -> BufferRange -> IO (BuildSignal r) - fill innerStep !(BufferRange op ope) - | outRemaining < minFree = - return $! bufferFull minFree op (fill innerStep) - | otherwise = do - fillWithBuildStep innerStep doneH fullH insertChunksH brInner - where - outRemaining = ope `minusPtr` op - sizeFE = mkSizeFE $ fromIntegral outRemaining - reservedBefore = I.size sizeFE - reservedAfter = minFree - reservedBefore - - -- leave enough free space such that all sizes can be encodded. - startInner = op `plusPtr` reservedBefore - opeInner = ope `plusPtr` (negate reservedAfter) - brInner = BufferRange startInner opeInner - - fastPrefixSize :: Ptr Word8 -> IO (Ptr Word8) - fastPrefixSize !opInner' - | innerSize == 0 = do runB (toB $ mkSizeFE 0) 0 op - | otherwise = do runF (sizeFE) innerSize op - return opInner' - where - innerSize = fromIntegral $ opInner' `minusPtr` startInner - - slowPrefixSize :: Ptr Word8 -> Builder -> BuildStep a -> IO (BuildSignal r) - slowPrefixSize opInner' bInner nextStep = do - (x, chunks, payLenChunks) <- toLBS $ runBuilderWith bInner nextStep - - let -- length of payload data in current buffer - payLenCur = opInner' `minusPtr` startInner - -- length of whole payload - payLen = fromIntegral payLenCur + fromIntegral payLenChunks - -- encoder for payload length - sizeFE' = mkSizeFE payLen - -- start of payload in current buffer with the payload - -- length encoded before - startInner' = op `plusPtr` I.size sizeFE' - - -- move data in current buffer out of the way, if required - unless (startInner == startInner') $ - moveBytes startInner' startInner payLenCur - -- encode payload length at start of the buffer - runF sizeFE' payLen op - -- TODO: If we were to change the CIOS definition such that it also - -- returns the last buffer for writing, we could also fill the - -- last buffer with 'k' and return the signal, once it is - -- filled, therefore avoiding unfilled space. - return $ insertChunks (startInner' `plusPtr` payLenCur) - payLenChunks - chunks - (k x) - where - toLBS = runCIOSWithLength <=< - buildStepToCIOSUntrimmedWith (fromIntegral innerBufSize) - - doneH :: Ptr Word8 -> a -> IO (BuildSignal r) - doneH opInner' x = do - op' <- fastPrefixSize opInner' - let !br' = BufferRange op' ope - k x br' - - fullH :: Ptr Word8 -> Int -> BuildStep a -> IO (BuildSignal r) - fullH opInner' minSize nextInnerStep = - slowPrefixSize opInner' (ensureFree minSize) nextInnerStep - - insertChunksH :: Ptr Word8 -> Int64 -> LazyByteStringC - -> BuildStep a -> IO (BuildSignal r) - insertChunksH opInner' n lbsC nextInnerStep = - slowPrefixSize opInner' (lazyByteStringC n lbsC) nextInnerStep - - --- | Run a 'ChunkIOStream' and gather its results and their length. -runCIOSWithLength :: ChunkIOStream a -> IO (a, LazyByteStringC, Int64) -runCIOSWithLength = - go 0 id - where - go !l lbsC (Finished x) = return (x, lbsC, l) - go !l lbsC (YieldC n lbsC' io) = io >>= go (l + n) (lbsC . lbsC') - go !l lbsC (Yield1 bs io) = - io >>= go (l + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) - --- | Run a 'BuildStep' using the untrimmed strategy. -buildStepToCIOSUntrimmedWith :: Int -> BuildStep a -> IO (ChunkIOStream a) -buildStepToCIOSUntrimmedWith bufSize = - buildStepToCIOS (untrimmedStrategy bufSize bufSize) - (return . Finished) - - ----------------------------------------------------------------------- --- Padded versions of encodings for streamed prefixing of output sizes ----------------------------------------------------------------------- - -{-# INLINE appsUntilZero #-} -appsUntilZero :: (Eq a, Num a) => (a -> a) -> a -> Int -appsUntilZero f x0 = - count 0 x0 - where - count !n 0 = n - count !n x = count (succ n) (f x) - - -{-# INLINE genericVarFixedBound #-} -genericVarFixedBound :: (Eq b, Show b, Bits b, Num a, Integral b) - => (b -> a -> b) -> b -> FixedEncoding b -genericVarFixedBound shiftRight bound = - fixedEncoding n0 io - where - n0 = max 1 $ appsUntilZero (`shiftRight` 7) bound - - io !x0 !op - | x0 > bound = error err - | otherwise = loop 0 x0 - where - err = "genericVarFixedBound: value " ++ show x0 ++ " > bound " ++ show bound - loop !n !x - | n0 <= n + 1 = do poke8 (x .&. 0x7f) - | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) - loop (n + 1) (x `shiftRight` 7) - where - poke8 = pokeElemOff op n . fromIntegral - -{-# INLINE wordVarFixedBound #-} -wordVarFixedBound :: Word -> FixedEncoding Word -wordVarFixedBound = genericVarFixedBound shiftr_w - -{-# INLINE word64VarFixedBound #-} -word64VarFixedBound :: Word64 -> FixedEncoding Word64 -word64VarFixedBound = genericVarFixedBound shiftr_w64 - - --- Somehow this function doesn't really make sense, as the bound must be --- greater when interpreted as an unsigned integer. These conversions and --- decisions should be left to the user. --- ---{-# INLINE intVarFixed #-} ---intVarFixed :: Size -> FixedEncoding Size ---intVarFixed bound = fromIntegral >$< wordVarFixed (fromIntegral bound) - -{-# INLINE genHexFixedBound #-} -genHexFixedBound :: (Num a, Bits a, Integral a) - => (a -> Int -> a) -> Char -> a -> FixedEncoding a -genHexFixedBound shiftr padding0 bound = - fixedEncoding n0 io - where - n0 = max 1 $ appsUntilZero (`shiftr` 4) bound - - padding = fromIntegral (ord padding0) :: Word8 - - io !x0 !op0 = - loop (op0 `plusPtr` n0) x0 - where - loop !op !x = do - let !op' = op `plusPtr` (-1) - poke op' =<< encode4_as_8 lowerTable (fromIntegral $ x .&. 0xf) - let !x' = x `shiftr` 4 - unless (op' <= op0) $ - if x' == 0 - then pad (op' `plusPtr` (-1)) - else loop op' x' - - pad !op - | op < op0 = return () - | otherwise = poke op padding >> pad (op `plusPtr` (-1)) - - -{-# INLINE wordHexFixedBound #-} -wordHexFixedBound :: Char -> Word -> FixedEncoding Word -wordHexFixedBound = genHexFixedBound shiftr_w - -{-# INLINE word64HexFixedBound #-} -word64HexFixedBound :: Char -> Word64 -> FixedEncoding Word64 -word64HexFixedBound = genHexFixedBound shiftr_w64 - --- | Note: Works only for positive numbers. -{-# INLINE genDecFixedBound #-} -genDecFixedBound :: (Num a, Bits a, Integral a) - => Char -> a -> FixedEncoding a -genDecFixedBound padding0 bound = - fixedEncoding n0 io - where - n0 = max 1 $ appsUntilZero (`div` 10) bound - - padding = fromIntegral (ord padding0) :: Word8 - - io !x0 !op0 = - loop (op0 `plusPtr` n0) x0 - where - loop !op !x = do - let !op' = op `plusPtr` (-1) - !x' = x `div` 10 - poke op' ((fromIntegral $ (x - x' * 10) + 48) :: Word8) - unless (op' <= op0) $ - if x' == 0 - then pad (op' `plusPtr` (-1)) - else loop op' x' - - pad !op - | op < op0 = return () - | otherwise = poke op padding >> pad (op `plusPtr` (-1)) - -{-# INLINE wordDecFixedBound #-} -wordDecFixedBound :: Char -> Word -> FixedEncoding Word -wordDecFixedBound = genDecFixedBound - -{-# INLINE word64DecFixedBound #-} -word64DecFixedBound :: Char -> Word64 -> FixedEncoding Word64 -word64DecFixedBound = genDecFixedBound - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-} -{-# OPTIONS_HADDOCK hide #-} --- | --- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- This module is internal. It is only intended to be used by the 'bytestring' --- and the 'text' library. Please contact the maintainer, if you need to use --- this module in your library. We are glad to accept patches for further --- standard encodings of standard Haskell values. --- --- If you need to write your own primitive encoding, then be aware that you are --- writing code with /all saftey belts off/; i.e., --- *this is the code that might make your application vulnerable to buffer-overflow attacks!* --- The "Codec.Bounded.Encoding.Internal.Test" module provides you with --- utilities for testing your encodings thoroughly. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal ( - -- * Fixed-size Encodings - Size - , FixedEncoding - , fixedEncoding - , size - , runF - - , emptyF - , contramapF - , pairF - -- , liftIOF - - , storableToF - - -- * Bounded-size Encodings - , BoundedEncoding - , boundedEncoding - , sizeBound - , runB - - , emptyB - , contramapB - , pairB - , eitherB - , ifB - - -- , liftIOB - - , toB - , fromF - - -- , withSizeFB - -- , withSizeBB - - -- * Shared operators - , (>$<) - , (>*<) - - ) where - -import Foreign -import Prelude hiding (maxBound) - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611 --- ghc-6.10 and older do not support {-# INLINE CONLIKE #-} -#define CONLIKE -#endif - ------------------------------------------------------------------------------- --- Supporting infrastructure ------------------------------------------------------------------------------- - --- | Contravariant functors as in the 'contravariant' package. -class Contravariant f where - contramap :: (b -> a) -> f a -> f b - -infixl 4 >$< - --- | An overloaded infix operator for 'contramapF' and 'contramapB'. --- --- We can use it for example to prepend and/or append fixed values to an --- encoding. --- --- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'" --- > where --- > fixed3 = char7 >*< char7 >*< char7 --- --- Note that the rather verbose syntax for composition stems from the --- requirement to be able to compute the 'size's and 'sizeBound's at --- compile time. --- -(>$<) :: Contravariant f => (b -> a) -> f a -> f b -(>$<) = contramap - - -instance Contravariant FixedEncoding where - contramap = contramapF - -instance Contravariant BoundedEncoding where - contramap = contramapB - - --- | Type-constructors supporting lifting of type-products. -class Monoidal f where - pair :: f a -> f b -> f (a, b) - -instance Monoidal FixedEncoding where - pair = pairF - -instance Monoidal BoundedEncoding where - pair = pairB - -infixr 5 >*< - --- | An overloaded infix operator for 'pairF' and 'pairB'. --- For example, --- --- >showF (char7 >*< char7) ('x','y') = "xy" --- --- We can combine multiple encodings using '>*<' multiple times. --- --- >showEncoding (char7 >*< char7 >*< char7) ('x',('y','z')) = "xyz" --- -(>*<) :: Monoidal f => f a -> f b -> f (a, b) -(>*<) = pair - - --- | The type used for sizes and sizeBounds of sizes. -type Size = Int - - ------------------------------------------------------------------------------- --- Fixed-size Encodings ------------------------------------------------------------------------------- - --- | An encoding that always results in a sequence of bytes of a --- pre-determined, fixed size. -data FixedEncoding a = FE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ()) - -fixedEncoding :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedEncoding a -fixedEncoding = FE - --- | The size of the sequences of bytes generated by this 'FixedEncoding'. -{-# INLINE CONLIKE size #-} -size :: FixedEncoding a -> Int -size (FE l _) = l - -{-# INLINE CONLIKE runF #-} -runF :: FixedEncoding a -> a -> Ptr Word8 -> IO () -runF (FE _ io) = io - --- | The 'FixedEncoding' that always results in the zero-length sequence. -{-# INLINE CONLIKE emptyF #-} -emptyF :: FixedEncoding a -emptyF = FE 0 (\_ _ -> return ()) - --- | Encode a pair by encoding its first component and then its second component. -{-# INLINE CONLIKE pairF #-} -pairF :: FixedEncoding a -> FixedEncoding b -> FixedEncoding (a, b) -pairF (FE l1 io1) (FE l2 io2) = - FE (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1)) - --- | Change an encoding such that it first applies a function to the value --- to be encoded. --- --- Note that encodings are 'Contrafunctors' --- . Hence, the following --- laws hold. --- --- >contramapF id = id --- >contramapF f . contramapF g = contramapF (g . f) -{-# INLINE CONLIKE contramapF #-} -contramapF :: (b -> a) -> FixedEncoding a -> FixedEncoding b -contramapF f (FE l io) = FE l (\x op -> io (f x) op) - --- | Convert a 'FixedEncoding' to a 'BoundedEncoding'. -{-# INLINE CONLIKE toB #-} -toB :: FixedEncoding a -> BoundedEncoding a -toB (FE l io) = BE l (\x op -> io x op >> (return $! op `plusPtr` l)) - --- | Convert a 'FixedEncoding' to a 'BoundedEncoding'. -{-# INLINE CONLIKE fromF #-} -fromF :: FixedEncoding a -> BoundedEncoding a -fromF = toB - -{-# INLINE CONLIKE storableToF #-} -storableToF :: forall a. Storable a => FixedEncoding a -storableToF = FE (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) - -{- -{-# INLINE CONLIKE liftIOF #-} -liftIOF :: FixedEncoding a -> FixedEncoding (IO a) -liftIOF (FE l io) = FE l (\xWrapped op -> do x <- xWrapped; io x op) --} - ------------------------------------------------------------------------------- --- Bounded-size Encodings ------------------------------------------------------------------------------- - --- | An encoding that always results in sequence of bytes that is no longer --- than a pre-determined bound. -data BoundedEncoding a = BE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8)) - --- | The bound on the size of sequences of bytes generated by this 'BoundedEncoding'. -{-# INLINE CONLIKE sizeBound #-} -sizeBound :: BoundedEncoding a -> Int -sizeBound (BE b _) = b - -boundedEncoding :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedEncoding a -boundedEncoding = BE - -{-# INLINE CONLIKE runB #-} -runB :: BoundedEncoding a -> a -> Ptr Word8 -> IO (Ptr Word8) -runB (BE _ io) = io - --- | Change a 'BoundedEncoding' such that it first applies a function to the --- value to be encoded. --- --- Note that 'BoundedEncoding's are 'Contrafunctors' --- . Hence, the following --- laws hold. --- --- >contramapB id = id --- >contramapB f . contramapB g = contramapB (g . f) -{-# INLINE CONLIKE contramapB #-} -contramapB :: (b -> a) -> BoundedEncoding a -> BoundedEncoding b -contramapB f (BE b io) = BE b (\x op -> io (f x) op) - --- | The 'BoundedEncoding' that always results in the zero-length sequence. -{-# INLINE CONLIKE emptyB #-} -emptyB :: BoundedEncoding a -emptyB = BE 0 (\_ op -> return op) - --- | Encode a pair by encoding its first component and then its second component. -{-# INLINE CONLIKE pairB #-} -pairB :: BoundedEncoding a -> BoundedEncoding b -> BoundedEncoding (a, b) -pairB (BE b1 io1) (BE b2 io2) = - BE (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2) - --- | Encode an 'Either' value using the first 'BoundedEncoding' for 'Left' --- values and the second 'BoundedEncoding' for 'Right' values. --- --- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below --- using '>$<') suffice to construct 'BoundedEncoding's for all non-recursive --- algebraic datatypes. For example, --- --- @ ---maybeB :: BoundedEncoding () -> BoundedEncoding a -> BoundedEncoding (Maybe a) ---maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just --- @ -{-# INLINE CONLIKE eitherB #-} -eitherB :: BoundedEncoding a -> BoundedEncoding b -> BoundedEncoding (Either a b) -eitherB (BE b1 io1) (BE b2 io2) = - BE (max b1 b2) - (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op) - --- | Conditionally select a 'BoundedEncoding'. --- For example, we can implement the ASCII encoding that drops characters with --- Unicode codepoints above 127 as follows. --- --- @ ---charASCIIDrop = 'ifB' (< '\128') ('fromF' 'char7') 'emptyB' --- @ -{-# INLINE CONLIKE ifB #-} -ifB :: (a -> Bool) -> BoundedEncoding a -> BoundedEncoding a -> BoundedEncoding a -ifB p be1 be2 = - contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2) - - -{- -{-# INLINE withSizeFB #-} -withSizeFB :: (Word -> FixedEncoding Word) -> BoundedEncoding a -> BoundedEncoding a -withSizeFB feSize (BE b io) = - BE (lSize + b) - (\x op0 -> do let !op1 = op0 `plusPtr` lSize - op2 <- io x op1 - ioSize (fromIntegral $ op2 `minusPtr` op1) op0 - return op2) - where - FE lSize ioSize = feSize (fromIntegral b) - - -{-# INLINE withSizeBB #-} -withSizeBB :: BoundedEncoding Word -> BoundedEncoding a -> BoundedEncoding a -withSizeBB (BE bSize ioSize) (BE b io) = - BE (bSize + 2*b) - (\x op0 -> do let !opTmp = op0 `plusPtr` (bSize + b) - opTmp' <- io x opTmp - let !s = opTmp' `minusPtr` opTmp - op1 <- ioSize (fromIntegral s) op0 - copyBytes op1 opTmp s - return $! op1 `plusPtr` s) - -{-# INLINE CONLIKE liftIOB #-} -liftIOB :: BoundedEncoding a -> BoundedEncoding (IO a) -liftIOB (BE l io) = BE l (\xWrapped op -> do x <- xWrapped; io x op) --} - ------------------------------------------------------------------------------- --- Encodings from 'ByteString's. ------------------------------------------------------------------------------- - -{- --- | A 'FixedEncoding' that always results in the same byte sequence given as a --- strict 'S.ByteString'. We can use this encoding to insert fixed ... -{-# INLINE CONLIKE constByteStringF #-} -constByteStringF :: S.ByteString -> FixedEncoding () -constByteStringF bs = - FE len io - where - (S.PS fp off len) = bs - io _ op = do - copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) len - touchForeignPtr fp - --- | Encode a fixed-length prefix of a strict 'S.ByteString' as-is. We can use --- this function to -{-# INLINE byteStringPrefixB #-} -byteStringTakeB :: Int -- ^ Length of the prefix. It should be smaller than - -- 100 bytes, as otherwise - -> BoundedEncoding S.ByteString -byteStringTakeB n0 = - BE n io - where - n = max 0 n0 -- sanitize - - io (S.PS fp off len) op = do - let !s = min len n - copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) s - touchForeignPtr fp - return $! op `plusPtr` s --} - -{- - -httpChunkedTransfer :: Builder -> Builder -httpChunkedTransfer = - encodeChunked 32 (word64HexFixedBound '0') - ((\_ -> ('\r',('\n',('\r','\n')))) >$< char8x4) - where - char8x4 = toB (char8 >*< char8 >*< char8 >*< char8) - - - -chunked :: Builder -> Builder -chunked = encodeChunked 16 word64VarFixedBound emptyB - --} - - - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- Hexadecimal encoding of nibbles (4-bit) and octets (8-bit) as ASCII --- characters. --- --- The current implementation is based on a table based encoding inspired by --- the code in the 'base64-bytestring' library by Bryan O'Sullivan. In our --- benchmarks on a 32-bit machine it turned out to be the fastest --- implementation option. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 ( - EncodingTable - -- , upperTable - , lowerTable - , encode4_as_8 - , encode8_as_16h - -- , encode8_as_8_8 - ) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - --- Creating the encoding tables -------------------------------- - --- TODO: Use table from C implementation. - --- | An encoding table for Base16 encoding. -newtype EncodingTable = EncodingTable (ForeignPtr Word8) - -tableFromList :: [Word8] -> EncodingTable -tableFromList xs = case S.pack xs of S.PS fp _ _ -> EncodingTable fp - -unsafeIndex :: EncodingTable -> Int -> IO Word8 -unsafeIndex (EncodingTable table) = peekElemOff (unsafeForeignPtrToPtr table) - -base16EncodingTable :: EncodingTable -> IO EncodingTable -base16EncodingTable alphabet = do - xs <- sequence $ concat $ [ [ix j, ix k] | j <- [0..15], k <- [0..15] ] - return $ tableFromList xs - where - ix = unsafeIndex alphabet - -{- -{-# NOINLINE upperAlphabet #-} -upperAlphabet :: EncodingTable -upperAlphabet = - tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['A'..'F'] - --- | The encoding table for hexadecimal values with upper-case characters; --- e.g., DEADBEEF. -{-# NOINLINE upperTable #-} -upperTable :: EncodingTable -upperTable = unsafePerformIO $ base16EncodingTable upperAlphabet --} - -{-# NOINLINE lowerAlphabet #-} -lowerAlphabet :: EncodingTable -lowerAlphabet = - tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['a'..'f'] - --- | The encoding table for hexadecimal values with lower-case characters; --- e.g., deadbeef. -{-# NOINLINE lowerTable #-} -lowerTable :: EncodingTable -lowerTable = unsafePerformIO $ base16EncodingTable lowerAlphabet - - --- Encoding nibbles and octets ------------------------------- - --- | Encode a nibble as an octet. --- --- > encode4_as_8 lowerTable 10 = fromIntegral (char 'a') --- -{-# INLINE encode4_as_8 #-} -encode4_as_8 :: EncodingTable -> Word8 -> IO Word8 -encode4_as_8 table x = unsafeIndex table (2 * fromIntegral x + 1) --- TODO: Use a denser table to reduce cache utilization. - --- | Encode an octet as 16bit word comprising both encoded nibbles ordered --- according to the host endianness. Writing these 16bit to memory will write --- the nibbles in the correct order (i.e. big-endian). -{-# INLINE encode8_as_16h #-} -encode8_as_16h :: EncodingTable -> Word8 -> IO Word16 -encode8_as_16h (EncodingTable table) = - peekElemOff (castPtr $ unsafeForeignPtrToPtr table) . fromIntegral - -{- --- | Encode an octet as a big-endian ordered tuple of octets; i.e., --- --- > encode8_as_8_8 lowerTable 10 --- > = (fromIntegral (chr '0'), fromIntegral (chr 'a')) --- -{-# INLINE encode8_as_8_8 #-} -encode8_as_8_8 :: EncodingTable -> Word8 -> IO (Word8, Word8) -encode8_as_8_8 table x = - (,) <$> unsafeIndex table i <*> unsafeIndex table (i + 1) - where - i = 2 * fromIntegral x --} diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Copyright : (c) 2010 Simon Meier --- --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- Conversion of 'Float's and 'Double's to 'Word32's and 'Word64's. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating - ( - -- coerceFloatToWord32 - -- , coerceDoubleToWord64 - encodeFloatViaWord32F - , encodeDoubleViaWord64F - ) where - -import Foreign -import Data.ByteString.Lazy.Builder.BasicEncoding.Internal - -{- -We work around ticket http://hackage.haskell.org/trac/ghc/ticket/4092 using the -FFI to store the Float/Double in the buffer and peek it out again from there. --} - - --- | Encode a 'Float' using a 'Word32' encoding. --- --- PRE: The 'Word32' encoding must have a size of at least 4 bytes. -{-# INLINE encodeFloatViaWord32F #-} -encodeFloatViaWord32F :: FixedEncoding Word32 -> FixedEncoding Float -encodeFloatViaWord32F w32fe - | size w32fe < sizeOf (undefined :: Float) = - error $ "encodeFloatViaWord32F: encoding not wide enough" - | otherwise = fixedEncoding (size w32fe) $ \x op -> do - poke (castPtr op) x - x' <- peek (castPtr op) - runF w32fe x' op - --- | Encode a 'Double' using a 'Word64' encoding. --- --- PRE: The 'Word64' encoding must have a size of at least 8 bytes. -{-# INLINE encodeDoubleViaWord64F #-} -encodeDoubleViaWord64F :: FixedEncoding Word64 -> FixedEncoding Double -encodeDoubleViaWord64F w64fe - | size w64fe < sizeOf (undefined :: Float) = - error $ "encodeDoubleViaWord64F: encoding not wide enough" - | otherwise = fixedEncoding (size w64fe) $ \x op -> do - poke (castPtr op) x - x' <- peek (castPtr op) - runF w64fe x' op - diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} --- | --- Copyright : (c) 2010 Simon Meier --- --- Original serialization code from 'Data.Binary.Builder': --- (c) Lennart Kolmodin, Ross Patterson --- --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Utilty module defining unchecked shifts. --- --- These functions are undefined when the amount being shifted by is --- greater than the size in bits of a machine Int#.- --- -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts ( - shiftr_w16 - , shiftr_w32 - , shiftr_w64 - , shiftr_w - - , caseWordSize_32_64 - ) where - - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base -import GHC.Word (Word32(..),Word16(..),Word64(..)) - -#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 -import GHC.Word (uncheckedShiftRL64#) -#endif -#else -import Data.Word -#endif - -import Foreign - - ------------------------------------------------------------------------- --- Unchecked shifts - --- | Right-shift of a 'Word16'. -{-# INLINE shiftr_w16 #-} -shiftr_w16 :: Word16 -> Int -> Word16 - --- | Right-shift of a 'Word32'. -{-# INLINE shiftr_w32 #-} -shiftr_w32 :: Word32 -> Int -> Word32 - --- | Right-shift of a 'Word64'. -{-# INLINE shiftr_w64 #-} -shiftr_w64 :: Word64 -> Int -> Word64 - --- | Right-shift of a 'Word'. -{-# INLINE shiftr_w #-} -shiftr_w :: Word -> Int -> Word -#if WORD_SIZE_IN_BITS < 64 -shiftr_w w s = fromIntegral $ (`shiftr_w32` s) $ fromIntegral w -#else -shiftr_w w s = fromIntegral $ (`shiftr_w64` s) $ fromIntegral w -#endif - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) - -#if WORD_SIZE_IN_BITS < 64 -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) - -#if __GLASGOW_HASKELL__ <= 606 --- Exported by GHC.Word in GHC 6.8 and higher -foreign import ccall unsafe "stg_uncheckedShiftRL64" - uncheckedShiftRL64# :: Word64# -> Int# -> Word64# -#endif - -#else -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) -#endif - -#else -shiftr_w16 = shiftR -shiftr_w32 = shiftR -shiftr_w64 = shiftR -#endif - - --- | Select an implementation depending on the bit-size of 'Word's. --- Currently, it produces a runtime failure if the bitsize is different. --- This is detected by the testsuite. -{-# INLINE caseWordSize_32_64 #-} -caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's - -> a -- Value to use for 64-bit 'Word's - -> a -caseWordSize_32_64 f32 f64 = case bitSize (undefined :: Word) of - 32 -> f32 - 64 -> f64 - s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s - - diff --git a/Data/ByteString/Lazy/Builder/Extras.hs b/Data/ByteString/Lazy/Builder/Extras.hs --- a/Data/ByteString/Lazy/Builder/Extras.hs +++ b/Data/ByteString/Lazy/Builder/Extras.hs @@ -1,125 +1,11 @@ -{-# LANGUAGE BangPatterns #-} ------------------------------------------------------------------------------ --- | Copyright : (c) 2010 Jasper Van der Jeugt --- (c) 2010-2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC --- --- Extra functions for creating and executing 'Builder's. They are intended --- for application-specific fine-tuning the performance of 'Builder's. --- ------------------------------------------------------------------------------ -module Data.ByteString.Lazy.Builder.Extras - ( - -- * Execution strategies - toLazyByteStringWith - , AllocationStrategy - , safeStrategy - , untrimmedStrategy - , smallChunkSize - , defaultChunkSize - -- * Controlling chunk boundaries - , byteStringCopy - , byteStringInsert - , byteStringThreshold - - , lazyByteStringCopy - , lazyByteStringInsert - , lazyByteStringThreshold - - , flush - - -- * Host-specific binary encodings - , intHost - , int16Host - , int32Host - , int64Host - - , wordHost - , word16Host - , word32Host - , word64Host - - , floatHost - , doubleHost - - ) where - - -import Data.ByteString.Lazy.Builder.Internal - -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E - - -import Foreign - - - ------------------------------------------------------------------------------- --- Host-specific encodings ------------------------------------------------------------------------------- - --- | Encode a single native machine 'Int'. The 'Int' is encoded in host order, --- host endian form, for the machine you're on. On a 64 bit machine the 'Int' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or int sized machines, without --- conversion. +-- | We decided to rename the Builder modules. Sorry about that. -- -{-# INLINE intHost #-} -intHost :: Int -> Builder -intHost = E.encodeWithF E.intHost - --- | Encode a 'Int16' in native host order and host endianness. -{-# INLINE int16Host #-} -int16Host :: Int16 -> Builder -int16Host = E.encodeWithF E.int16Host - --- | Encode a 'Int32' in native host order and host endianness. -{-# INLINE int32Host #-} -int32Host :: Int32 -> Builder -int32Host = E.encodeWithF E.int32Host - --- | Encode a 'Int64' in native host order and host endianness. -{-# INLINE int64Host #-} -int64Host :: Int64 -> Builder -int64Host = E.encodeWithF E.int64Host - --- | Encode a single native machine 'Word'. The 'Word' is encoded in host order, --- host endian form, for the machine you're on. On a 64 bit machine the 'Word' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way --- are not portable to different endian or word sized machines, without --- conversion. +-- The old names will hang about for at least once release cycle before we +-- deprecate them and then later remove them. -- -{-# INLINE wordHost #-} -wordHost :: Word -> Builder -wordHost = E.encodeWithF E.wordHost - --- | Encode a 'Word16' in native host order and host endianness. -{-# INLINE word16Host #-} -word16Host :: Word16 -> Builder -word16Host = E.encodeWithF E.word16Host - --- | Encode a 'Word32' in native host order and host endianness. -{-# INLINE word32Host #-} -word32Host :: Word32 -> Builder -word32Host = E.encodeWithF E.word32Host - --- | Encode a 'Word64' in native host order and host endianness. -{-# INLINE word64Host #-} -word64Host :: Word64 -> Builder -word64Host = E.encodeWithF E.word64Host - --- | Encode a 'Float' in native host order. Values encoded this way are not --- portable to different endian machines, without conversion. -{-# INLINE floatHost #-} -floatHost :: Float -> Builder -floatHost = E.encodeWithF E.floatHost - --- | Encode a 'Double' in native host order. -{-# INLINE doubleHost #-} -doubleHost :: Double -> Builder -doubleHost = E.encodeWithF E.doubleHost +module Data.ByteString.Lazy.Builder.Extras ( + module Data.ByteString.Builder.Extra +) where +import Data.ByteString.Builder.Extra diff --git a/Data/ByteString/Lazy/Builder/Internal.hs b/Data/ByteString/Lazy/Builder/Internal.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Builder/Internal.hs +++ /dev/null @@ -1,854 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, Rank2Types #-} -{-# OPTIONS_HADDOCK hide #-} --- | Copyright : (c) 2010 - 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : GHC --- --- Core types and functions for the 'Builder' monoid and its generalization, --- the 'Put' monad. --- --- The design of the 'Builder' monoid is optimized such that --- --- 1. buffers of arbitrary size can be filled as efficiently as possible and --- --- 2. sequencing of 'Builder's is as cheap as possible. --- --- We achieve (1) by completely handing over control over writing to the buffer --- to the 'BuildStep' implementing the 'Builder'. This 'BuildStep' is just told --- the start and the end of the buffer (represented as a 'BufferRange'). Then, --- the 'BuildStep' can write to as big a prefix of this 'BufferRange' in any --- way it desires. If the 'BuildStep' is done, the 'BufferRange' is full, or a --- long sequence of bytes should be inserted directly, then the 'BuildStep' --- signals this to its caller using a 'BuildSignal'. --- --- We achieve (2) by requiring that every 'Builder' is implemented by a --- 'BuildStep' that takes a continuation 'BuildStep', which it calls with the --- updated 'BufferRange' after it is done. Therefore, only two pointers have --- to be passed in a function call to implement concatenation of 'Builder's. --- Moreover, many 'Builder's are completely inlined, which enables the compiler --- to sequence them without a function call and with no boxing at all. --- --- This design gives the implementation of a 'Builder' full access to the 'IO' --- monad. Therefore, utmost care has to be taken to not overwrite anything --- outside the given 'BufferRange's. Moreover, further care has to be taken to --- ensure that 'Builder's and 'Put's are referentially transparent. See the --- comments of the 'builder' and 'put' functions for further information. --- Note that there are /no safety belts/ at all, when implementing a 'Builder' --- using an 'IO' action: you are writing code that might enable the next --- buffer-overflow attack on a Haskell server! --- -module Data.ByteString.Lazy.Builder.Internal ( - - -- * Build signals and steps - BufferRange(..) - , LazyByteStringC - - , BuildSignal - , BuildStep - - , done - , bufferFull - , insertChunks - - , fillWithBuildStep - - -- * The Builder monoid - , Builder - , builder - , runBuilder - , runBuilderWith - - -- ** Primitive combinators - , empty - , append - , flush - , ensureFree - - , byteStringCopy - , byteStringInsert - , byteStringThreshold - - , lazyByteStringCopy - , lazyByteStringInsert - , lazyByteStringThreshold - - , lazyByteStringC - - , maximalCopySize - , byteString - , lazyByteString - - -- ** Execution strategies - , toLazyByteStringWith - , AllocationStrategy - , safeStrategy - , untrimmedStrategy - , L.smallChunkSize - , L.defaultChunkSize - - -- * The Put monad - , Put - , put - , runPut - , hPut - - -- ** Streams of chunks interleaved with IO - , ChunkIOStream(..) - , buildStepToCIOS - , ciosToLazyByteString - - -- ** Conversion to and from Builders - , putBuilder - , fromPut - - -- ** Lifting IO actions - -- , putLiftIO - -) where - -import Control.Applicative (Applicative(..), (<$>)) - -import Data.Monoid -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L - -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Buffer (Buffer(..), newByteBuffer) -import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) -import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) -import System.IO (hFlush, BufferMode(..)) -import Data.IORef -#else -import qualified Data.ByteString.Lazy as L -#endif -import System.IO (Handle) - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - - -type LazyByteStringC = L.ByteString -> L.ByteString - --- | A range of bytes in a buffer represented by the pointer to the first byte --- of the range and the pointer to the first byte /after/ the range. -data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range - {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range - - ------------------------------------------------------------------------------- --- Build signals ------------------------------------------------------------------------------- - --- | 'BuildStep's may assume that they are called at most once. However, --- they must not execute any function that may rise an async. exception, --- as this would invalidate the code of 'hPut' below. -type BuildStep a = BufferRange -> IO (BuildSignal a) - --- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are --- exactly three signals: 'done', 'bufferFull', and 'insertChunks'. -data BuildSignal a = - Done {-# UNPACK #-} !(Ptr Word8) a - | BufferFull - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Ptr Word8) - !(BuildStep a) - | InsertChunks - {-# UNPACK #-} !(Ptr Word8) - {-# UNPACK #-} !Int64 -- size of bytes in continuation - LazyByteStringC - !(BuildStep a) - --- | Signal that the current 'BuildStep' is done and has computed a value. -{-# INLINE done #-} -done :: Ptr Word8 -- ^ Next free byte in current 'BufferRange' - -> a -- ^ Computed value - -> BuildSignal a -done = Done - --- | Signal that the current buffer is full. -{-# INLINE bufferFull #-} -bufferFull :: Int - -- ^ Minimal size of next 'BufferRange'. - -> Ptr Word8 - -- ^ Next free byte in current 'BufferRange'. - -> BuildStep a - -- ^ 'BuildStep' to run on the next 'BufferRange'. This 'BuildStep' - -- may assume that it is called with a 'BufferRange' of at least the - -- required minimal size; i.e., the caller of this 'BuildStep' must - -- guarantee this. - -> BuildSignal a -bufferFull = BufferFull - --- TODO: Decide whether we should inline the bytestring constructor. --- Therefore, making builders independent of strict bytestrings. - --- | Signal that several chunks should be inserted directly. -{-# INLINE insertChunks #-} -insertChunks :: Ptr Word8 - -- ^ Next free byte in current 'BufferRange' - -> Int64 - -- ^ Number of bytes in 'L.ByteString' continuation. - -> (L.ByteString -> L.ByteString) - -- ^ Chunks to insert. - -> BuildStep a - -- ^ 'BuildStep' to run on next 'BufferRange' - -> BuildSignal a -insertChunks = InsertChunks - --- | Fill a 'BufferRange' using a 'BuildStep'. -{-# INLINE fillWithBuildStep #-} -fillWithBuildStep - :: BuildStep a - -- ^ Build step to use for filling the 'BufferRange'. - -> (Ptr Word8 -> a -> IO b) - -- ^ Handling the 'done' signal - -> (Ptr Word8 -> Int -> BuildStep a -> IO b) - -- ^ Handling the 'bufferFull' signal - -> (Ptr Word8 -> Int64 -> LazyByteStringC -> BuildStep a -> IO b) - -- ^ Handling the 'insertChunks' signal - -> BufferRange - -- ^ Buffer range to fill. - -> IO b - -- ^ Value computed by filling this 'BufferRange'. -fillWithBuildStep step fDone fFull fChunk !br = do - signal <- step br - case signal of - Done op x -> fDone op x - BufferFull minSize op nextStep -> fFull op minSize nextStep - InsertChunks op len lbsC nextStep -> fChunk op len lbsC nextStep - - - ------------------------------------------------------------------------------- --- The 'Builder' monoid ------------------------------------------------------------------------------- - --- | 'Builder's denote sequences of bytes. --- They are 'Monoid's where --- 'mempty' is the zero-length sequence and --- 'mappend' is concatenation, which runs in /O(1)/. -newtype Builder = Builder (forall r. BuildStep r -> BuildStep r) - --- | Construct a 'Builder'. In contrast to 'BuildStep's, 'Builder's are --- referentially transparent. -{-# INLINE builder #-} -builder :: (forall r. BuildStep r -> BuildStep r) - -- ^ A function that fills a 'BufferRange', calls the continuation with - -- the updated 'BufferRange' once its done, and signals its caller how - -- to proceed using 'done', 'bufferFull', or 'insertChunk'. - -- - -- This function must be referentially transparent; i.e., calling it - -- multiple times must result in the same sequence of bytes being - -- written. If you need mutable state, then you must allocate it newly - -- upon each call of this function. Moroever, this function must call - -- the continuation once its done. Otherwise, concatenation of - -- 'Builder's does not work. Finally, this function must write to all - -- bytes that it claims it has written. Otherwise, the resulting - -- 'Builder' is not guaranteed to be referentially transparent and - -- sensitive data might leak. - -> Builder -builder = Builder - --- | Run a 'Builder'. -{-# INLINE runBuilder #-} -runBuilder :: Builder -- ^ 'Builder' to run - -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this - -- 'Builder' and signals 'done' upon completion. -runBuilder (Builder b) = b $ \(BufferRange op _) -> return $ done op () - --- | Run a 'Builder'. -{-# INLINE runBuilderWith #-} -runBuilderWith :: Builder -- ^ 'Builder' to run - -> BuildStep a -- ^ Continuation 'BuildStep' - -> BuildStep a -runBuilderWith (Builder b) = b - --- | The 'Builder' denoting a zero-length sequence of bytes. This function is --- only exported for use in rewriting rules. Use 'mempty' otherwise. -{-# INLINE[1] empty #-} -empty :: Builder -empty = Builder id - --- | Concatenate two 'Builder's. This function is only exported for use in rewriting --- rules. Use 'mappend' otherwise. -{-# INLINE[1] append #-} -append :: Builder -> Builder -> Builder -append (Builder b1) (Builder b2) = Builder $ b1 . b2 - -instance Monoid Builder where - {-# INLINE mempty #-} - mempty = empty - {-# INLINE mappend #-} - mappend = append - {-# INLINE mconcat #-} - mconcat = foldr mappend mempty - --- | Flush the current buffer. This introduces a chunk boundary. --- -{-# INLINE flush #-} -flush :: Builder -flush = builder step - where - step k !(BufferRange op _) = return $ insertChunks op 0 id k - - ------------------------------------------------------------------------------- --- Put ------------------------------------------------------------------------------- - --- | A 'Put' action denotes a computation of a value that writes a stream of --- bytes as a side-effect. 'Put's are strict in their side-effect; i.e., the --- stream of bytes will always be written before the computed value is --- returned. --- --- 'Put's are a generalization of 'Builder's. They are used when values need to --- be returned during the computation of a stream of bytes. For example, when --- performing a block-based encoding of 'S.ByteString's like Base64 encoding, --- there might be a left-over partial block. Using the 'Put' monad, this --- partial block can be returned after the complete blocks have been encoded. --- Then, in a later step when more input is known, this partial block can be --- completed and also encoded. --- --- @Put ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' --- and 'fromPut' convert between these two types. Where possible, you should --- use 'Builder's, as they are slightly cheaper than 'Put's because they do not --- carry a computed value. -newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } - --- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are --- referentially transparent in the sense that sequencing the same 'Put' --- multiple times yields every time the same value with the same side-effect. -{-# INLINE put #-} -put :: (forall r. (a -> BuildStep r) -> BuildStep r) - -- ^ A function that fills a 'BufferRange', calls the continuation with - -- the updated 'BufferRange' and its computed value once its done, and - -- signals its caller how to proceed using 'done', 'bufferFull', or - -- 'insertChunk'. - -- - -- This function must be referentially transparent; i.e., calling it - -- multiple times must result in the same sequence of bytes being - -- written and the same value being computed. If you need mutable state, - -- then you must allocate it newly upon each call of this function. - -- Moroever, this function must call the continuation once its done. - -- Otherwise, monadic sequencing of 'Put's does not work. Finally, this - -- function must write to all bytes that it claims it has written. - -- Otherwise, the resulting 'Put' is not guaranteed to be referentially - -- transparent and sensitive data might leak. - -> Put a -put = Put - --- | Run a 'Put'. -{-# INLINE runPut #-} -runPut :: Put a -- ^ Put to run - -> BuildStep a -- ^ 'BuildStep' that first writes the byte stream of - -- this 'Put' and then yields the computed value using - -- the 'done' signal. -runPut (Put p) = p $ \x (BufferRange op _) -> return $ Done op x - -instance Functor Put where - fmap f p = Put $ \k -> unPut p (\x -> k (f x)) - {-# INLINE fmap #-} - -instance Applicative Put where - {-# INLINE pure #-} - pure x = Put $ \k -> k x - {-# INLINE (<*>) #-} - Put f <*> Put a = Put $ \k -> f (\f' -> a (\a' -> k (f' a'))) -#if MIN_VERSION_base(4,2,0) - {-# INLINE (<*) #-} - Put a <* Put b = Put $ \k -> a (\a' -> b (\_ -> k a')) - {-# INLINE (*>) #-} - Put a *> Put b = Put $ \k -> a (\_ -> b k) -#endif - -instance Monad Put where - {-# INLINE return #-} - return x = Put $ \k -> k x - {-# INLINE (>>=) #-} - Put m >>= f = Put $ \k -> m (\m' -> unPut (f m') k) - {-# INLINE (>>) #-} - Put m >> Put n = Put $ \k -> m (\_ -> n k) - - --- Conversion between Put and Builder -------------------------------------- - --- | Run a 'Builder' as a side-effect of a @Put ()@ action. -{-# INLINE putBuilder #-} -putBuilder :: Builder -> Put () -putBuilder (Builder b) = Put $ \k -> b (k ()) - --- | Convert a @Put ()@ action to a 'Builder'. -{-# INLINE fromPut #-} -fromPut :: Put () -> Builder -fromPut (Put p) = Builder $ \k -> p (\_ -> k) - - --- Lifting IO actions ---------------------- - -{- --- | Lift an 'IO' action to a 'Put' action. -{-# INLINE putLiftIO #-} -putLiftIO :: IO a -> Put a -putLiftIO io = put $ \k br -> io >>= (`k` br) --} - - ------------------------------------------------------------------------------- --- Executing a Put directly on a buffered Handle ------------------------------------------------------------------------------- - --- | Run a 'Put' action redirecting the produced output to a 'Handle'. --- --- The output is buffered using the 'Handle's associated buffer. If this --- buffer is too small to execute one step of the 'Put' action, then --- it is replaced with a large enough buffer. -hPut :: forall a. Handle -> Put a -> IO a -#if __GLASGOW_HASKELL__ >= 611 -hPut h p = do - fillHandle 1 (runPut p) - where - fillHandle :: Int -> BuildStep a -> IO a - fillHandle !minFree step = do - next <- wantWritableHandle "hPut" h fillHandle_ - next - where - -- | We need to return an inner IO action that is executed outside - -- the lock taken on the Handle for two reasons: - -- - -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that - -- we should never do any side-effecting operations before - -- an interruptible operation that may raise an async. exception - -- as long as we are inside 'wantWritableHandle' and the like. - -- We possibly run the interuptible 'flushWriteBuffer' right at - -- the start of 'fillHandle', hence entering it a second time is - -- not safe, as it could lead to a 'BuildStep' being run twice. - -- - -- 2. We use the 'S.hPut' function to also write to the handle. - -- This function tries to take the same lock taken by - -- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut' - -- inside 'wantWritableHandle'. - -- - fillHandle_ :: Handle__ -> IO (IO a) - fillHandle_ h_ = do - makeSpace =<< readIORef refBuf - fillBuffer =<< readIORef refBuf - where - refBuf = haByteBuffer h_ - freeSpace buf = bufSize buf - bufR buf - - makeSpace buf - | bufSize buf < minFree = do - flushWriteBuffer h_ - s <- bufState <$> readIORef refBuf - newByteBuffer minFree s >>= writeIORef refBuf - - | freeSpace buf < minFree = flushWriteBuffer h_ - | otherwise = -#if __GLASGOW_HASKELL__ >= 613 - return () -#else - -- required for ghc-6.12 - flushWriteBuffer h_ -#endif - - fillBuffer buf - | freeSpace buf < minFree = - error $ unlines - [ "Data.ByteString.Lazy.Builder.Internal.hPut: internal error." - , " Not enough space after flush." - , " required: " ++ show minFree - , " free: " ++ show (freeSpace buf) - ] - | otherwise = do - let !br = BufferRange op (pBuf `plusPtr` bufSize buf) - res <- fillWithBuildStep step doneH fullH insertChunksH br - touchForeignPtr fpBuf - return res - where - fpBuf = bufRaw buf - pBuf = unsafeForeignPtrToPtr fpBuf - op = pBuf `plusPtr` bufR buf - - {-# INLINE updateBufR #-} - updateBufR op' = do - let !off' = op' `minusPtr` pBuf - !buf' = buf {bufR = off'} - writeIORef refBuf buf' - - doneH op' x = do - updateBufR op' - -- We must flush if this Handle is set to NoBuffering. - -- If it is set to LineBuffering, be conservative and - -- flush anyway (we didn't check for newlines in the data). - -- Flushing must happen outside this 'wantWriteableHandle' - -- due to the possible async. exception. - case haBufferMode h_ of - BlockBuffering _ -> return $ return x - _line_or_no_buffering -> return $ hFlush h >> return x - - fullH op' minSize nextStep = do - updateBufR op' - return $ fillHandle minSize nextStep - -- 'fillHandle' will flush the buffer (provided there is - -- really less than 'minSize' space left) before executing - -- the 'nextStep'. - - insertChunksH op' _ lbsC nextStep = do - updateBufR op' - return $ do - L.foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) - (lbsC L.Empty) - fillHandle 1 nextStep -#else -hPut h p = - go =<< buildStepToCIOS strategy (return . Finished) (runPut p) - where - go (Finished k) = return k - go (Yield1 bs io) = S.hPut h bs >> io >>= go - go (YieldC _ lbsC io) = L.hPut h (lbsC L.Empty) >> io >>= go - strategy = untrimmedStrategy L.smallChunkSize L.defaultChunkSize -#endif - ------------------------------------------------------------------------------- --- ByteString insertion / controlling chunk boundaries ------------------------------------------------------------------------------- - --- Raw memory -------------- - --- | Ensure that there are at least 'n' free bytes for the following 'Builder'. -{-# INLINE ensureFree #-} -ensureFree :: Int -> Builder -ensureFree minFree = - builder step - where - step k br@(BufferRange op ope) - | ope `minusPtr` op < minFree = return $ bufferFull minFree op k - | otherwise = k br - --- | Copy the bytes from a 'BufferRange' into the output stream. -{-# INLINE bytesCopyStep #-} -bytesCopyStep :: BufferRange -- ^ Input 'BufferRange'. - -> BuildStep a -> BuildStep a -bytesCopyStep !(BufferRange ip0 ipe) k = - go ip0 - where - go !ip !(BufferRange op ope) - | inpRemaining <= outRemaining = do - copyBytes op ip inpRemaining - let !br' = BufferRange (op `plusPtr` inpRemaining) ope - k br' - | otherwise = do - copyBytes op ip outRemaining - let !ip' = ip `plusPtr` outRemaining - return $ bufferFull 1 ope (go ip') - where - outRemaining = ope `minusPtr` op - inpRemaining = ipe `minusPtr` ip - - - --- Strict ByteStrings ------------------------------------------------------------------------------- - - --- | Construct a 'Builder' that copies the strict 'S.ByteString's, if it is --- smaller than the treshold, and inserts it directly otherwise. --- --- For example, @byteStringThreshold 1024@ copies strict 'S.ByteString's whose size --- is less or equal to 1kb, and inserts them directly otherwise. This implies --- that the average chunk-size of the generated lazy 'L.ByteString' may be as --- low as 513 bytes, as there could always be just a single byte between the --- directly inserted 1025 byte, strict 'S.ByteString's. --- -{-# INLINE byteStringThreshold #-} -byteStringThreshold :: Int -> S.ByteString -> Builder -byteStringThreshold maxCopySize = - \bs -> builder $ step bs - where - step !bs@(S.PS _ _ len) !k br@(BufferRange !op _) - | len <= maxCopySize = byteStringCopyStep bs k br - | otherwise = - return $! insertChunks op (fromIntegral len) (L.chunk bs) k - --- | Construct a 'Builder' that copies the strict 'S.ByteString'. --- --- Use this function to create 'Builder's from smallish (@<= 4kb@) --- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not --- shared with the chunks generated by the 'Builder'. --- -{-# INLINE byteStringCopy #-} -byteStringCopy :: S.ByteString -> Builder -byteStringCopy = \bs -> builder $ byteStringCopyStep bs - -{-# INLINE byteStringCopyStep #-} -byteStringCopyStep :: S.ByteString -> BuildStep a -> BuildStep a -byteStringCopyStep (S.PS ifp ioff isize) !k0 = - bytesCopyStep (BufferRange ip ipe) k - where - ip = unsafeForeignPtrToPtr ifp `plusPtr` ioff - ipe = ip `plusPtr` isize - k br = do touchForeignPtr ifp -- input consumed: OK to release here - k0 br - --- | Construct a 'Builder' that always inserts the strict 'S.ByteString' --- directly as a chunk. --- --- This implies flushing the output buffer, even if it contains just --- a single byte. You should therefore use 'byteStringInsert' only for large --- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too --- fragmented to be processed efficiently afterwards. --- -{-# INLINE byteStringInsert #-} -byteStringInsert :: S.ByteString -> Builder -byteStringInsert = - \bs -> builder $ step bs - where - step !bs k !br@(BufferRange op _) - | S.null bs = k br - | otherwise = - return $ insertChunks op (fromIntegral $ S.length bs) (L.Chunk bs) k - - --- Lazy bytestrings ------------------------------------------------------------------------------- - --- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold' --- for each chunk of the lazy 'L.ByteString'. --- -{-# INLINE lazyByteStringThreshold #-} -lazyByteStringThreshold :: Int -> L.ByteString -> Builder -lazyByteStringThreshold maxCopySize = - L.foldrChunks (\bs b -> byteStringThreshold maxCopySize bs `mappend` b) mempty - -- TODO: We could do better here. Currently, Large, Small, Large, leads to - -- an unnecessary copy of the 'Small' chunk. - --- | Construct a 'Builder' that copies the lazy 'L.ByteString'. --- -{-# INLINE lazyByteStringCopy #-} -lazyByteStringCopy :: L.ByteString -> Builder -lazyByteStringCopy = - L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty - - --- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString' --- directly. --- -{-# INLINE lazyByteStringInsert #-} -lazyByteStringInsert :: L.ByteString -> Builder -lazyByteStringInsert = - \lbs -> builder $ step lbs - where - step L.Empty k br = k br - step lbs k (BufferRange op _) = case go 0 id lbs of - (n, lbsC) -> return $ insertChunks op n lbsC k - - go !n lbsC L.Empty = (n, lbsC) - go !n lbsC (L.Chunk bs lbs) = - go (n + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) lbs - - --- | Create a 'Builder' denoting the same sequence of bytes as a strict --- 'S.ByteString'. --- The 'Builder' inserts large 'S.ByteString's directly, but copies small ones --- to ensure that the generated chunks are large on average. --- -{-# INLINE byteString #-} -byteString :: S.ByteString -> Builder -byteString = byteStringThreshold maximalCopySize - --- | Create a 'Builder' denoting the same sequence of bytes as a lazy --- 'S.ByteString'. --- The 'Builder' inserts large chunks of the lazy 'L.ByteString' directly, --- but copies small ones to ensure that the generated chunks are large on --- average. --- -{-# INLINE lazyByteString #-} -lazyByteString :: L.ByteString -> Builder -lazyByteString = lazyByteStringThreshold maximalCopySize --- FIXME: also insert the small chunk for [large,small,large] directly. --- Perhaps it makes even sense to concatenate the small chunks in --- [large,small,small,small,large] and insert them directly afterwards to avoid --- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency --- => no good! - --- | The maximal size of a 'S.ByteString' that is copied. --- @2 * 'L.smallChunkSize'@ to guarantee that on average a chunk is of --- 'L.smallChunkSize'. -maximalCopySize :: Int -maximalCopySize = 2 * L.smallChunkSize - --- LazyByteStringC: difference lists of lazy bytestrings --------------------------------------------------------- - --- | Insert a 'LazyByteStringC' of the given size directly. -{-# INLINE lazyByteStringC #-} -lazyByteStringC :: Int64 -> LazyByteStringC -> Builder -lazyByteStringC n lbsC = - builder $ \k (BufferRange op _) -> return $ insertChunks op n lbsC k - ------------------------------------------------------------------------------- --- Builder execution ------------------------------------------------------------------------------- - --- | A buffer allocation strategy for executing 'Builder's. - --- The strategy --- --- > 'AllocationStrategy' firstBufSize bufSize trim --- --- states that the first buffer is of size @firstBufSize@, all following buffers --- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should --- be trimmed iff @trim k n@ is 'True'. -data AllocationStrategy = AllocationStrategy - {-# UNPACK #-} !Int -- size of first buffer - {-# UNPACK #-} !Int -- size of successive buffers - (Int -> Int -> Bool) -- trim - --- | Sanitize a buffer size; i.e., make it at least the size of a 'Int'. -{-# INLINE sanitize #-} -sanitize :: Int -> Int -sanitize = max (sizeOf (undefined :: Int)) - --- | Use this strategy for generating lazy 'L.ByteString's whose chunks are --- discarded right after they are generated. For example, if you just generate --- them to write them to a network socket. -{-# INLINE untrimmedStrategy #-} -untrimmedStrategy :: Int -- ^ Size of the first buffer - -> Int -- ^ Size of successive buffers - -> AllocationStrategy - -- ^ An allocation strategy that does not trim any of the - -- filled buffers before converting it to a chunk. -untrimmedStrategy firstSize bufSize = - AllocationStrategy (sanitize firstSize) (sanitize bufSize) (\_ _ -> False) - - --- | Use this strategy for generating lazy 'L.ByteString's whose chunks are --- likely to survive one garbage collection. This strategy trims buffers --- that are filled less than half in order to avoid spilling too much memory. -{-# INLINE safeStrategy #-} -safeStrategy :: Int -- ^ Size of first buffer - -> Int -- ^ Size of successive buffers - -> AllocationStrategy - -- ^ An allocation strategy that guarantees that at least half - -- of the allocated memory is used for live data -safeStrategy firstSize bufSize = - AllocationStrategy (sanitize firstSize) (sanitize bufSize) - (\used size -> 2*used < size) - --- | Execute a 'Builder' with custom execution parameters. --- --- This function is forced to be inlined to allow fusing with the allocation --- strategy despite its rather heavy code-size. We therefore recommend --- that you introduce a top-level function once you have fixed your strategy. --- This avoids unnecessary code duplication. --- For example, the default 'Builder' execution function 'toLazyByteString' is --- defined as follows. --- --- @ --- {-# NOINLINE toLazyByteString #-} --- toLazyByteString = --- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') empty --- @ --- --- where @empty@ is the zero-length lazy 'L.ByteString'. --- --- In most cases, the parameters used by 'toLazyByteString' give good --- performance. A sub-performing case of 'toLazyByteString' is executing short --- (<128 bytes) 'Builder's. In this case, the allocation overhead for the first --- 4kb buffer and the trimming cost dominate the cost of executing the --- 'Builder'. You can avoid this problem using --- --- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) empty --- --- This reduces the allocation and trimming overhead, as all generated --- 'L.ByteString's fit into the first buffer and there is no trimming --- required, if more than 64 bytes are written. --- -{-# INLINE toLazyByteStringWith #-} -toLazyByteStringWith - :: AllocationStrategy - -- ^ Buffer allocation strategy to use - -> L.ByteString - -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy - -- 'L.ByteString' - -> Builder - -- ^ Builder to execute - -> L.ByteString - -- ^ Resulting lazy 'L.ByteString' -toLazyByteStringWith strategy k b = - ciosToLazyByteString k $ unsafePerformIO $ - buildStepToCIOS strategy (return . Finished) (runBuilder b) - --- | A stream of non-empty chunks interleaved with 'IO'. -data ChunkIOStream a = - Finished a - | Yield1 {-# UNPACK #-} !S.ByteString (IO (ChunkIOStream a)) - | YieldC {-# UNPACK #-} !Int64 LazyByteStringC (IO (ChunkIOStream a)) - -{-# INLINE ciosToLazyByteString #-} -ciosToLazyByteString :: L.ByteString -> ChunkIOStream () -> L.ByteString -ciosToLazyByteString k = go - where - go (Finished _) = k - go (Yield1 bs io) = L.Chunk bs $ unsafePerformIO (go <$> io) - go (YieldC _ lbsC io) = lbsC $ unsafePerformIO (go <$> io) - -{-# INLINE buildStepToCIOS #-} -buildStepToCIOS - :: AllocationStrategy -- ^ Buffer allocation strategy to use - -> (a -> IO (ChunkIOStream b)) -- ^ Continuation stream constructor. - -> BuildStep a -- ^ 'Put' to execute - -> IO (ChunkIOStream b) -buildStepToCIOS (AllocationStrategy firstSize bufSize trim) k = - \step -> fillNew step firstSize - where - fillNew !step0 !size = do - S.mallocByteString size >>= fill step0 - where - fill !step !fpbuf = do - res <- fillWithBuildStep step doneH fullH insertChunksH br - touchForeignPtr fpbuf - return res - where - op = unsafeForeignPtrToPtr fpbuf -- safe due to mkCIOS - pe = op `plusPtr` size - br = BufferRange op pe - - doneH op' x = wrapChunk op' (const $ k x) - - fullH op' minSize nextStep = - wrapChunk op' (const $ fillNew nextStep (max minSize bufSize)) - - insertChunksH op' n lbsC nextStep = - wrapChunk op' $ \isEmpty -> return $ YieldC n lbsC $ - -- Checking for empty case avoids allocating 'n-1' empty - -- buffers for 'n' insertChunksH right after each other. - if isEmpty - then fill nextStep fpbuf - else fillNew nextStep bufSize - - -- Yield a chunk, trimming it if necesary - {-# INLINE wrapChunk #-} - wrapChunk !op' mkCIOS - | pe < op' = error $ - "buildStepToCIOS: overwrite by " ++ show (op' `minusPtr` pe) ++ " bytes" - | chunkSize == 0 = mkCIOS True - | trim chunkSize size = do - bs <- S.create chunkSize $ \pbuf -> copyBytes pbuf op chunkSize - return $ Yield1 bs (mkCIOS False) - | otherwise = - return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False) - where - chunkSize = op' `minusPtr` op diff --git a/Data/ByteString/Lazy/Char8.hs b/Data/ByteString/Lazy/Char8.hs --- a/Data/ByteString/Lazy/Char8.hs +++ b/Data/ByteString/Lazy/Char8.hs @@ -54,6 +54,7 @@ uncons, -- :: ByteString -> Maybe (Char, ByteString) last, -- :: ByteString -> Char tail, -- :: ByteString -> ByteString + unsnoc, -- :: ByteString -> Maybe (ByteString, Char) init, -- :: ByteString -> ByteString null, -- :: ByteString -> Bool length, -- :: ByteString -> Int64 @@ -220,7 +221,7 @@ ,readFile,writeFile,appendFile,replicate,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem,repeat,iterate,interact,cycle) -import System.IO (Handle,stdout,hClose,openFile,IOMode(..)) +import System.IO (Handle,stdout,hClose,openBinaryFile,IOMode(..)) #ifndef __NHC__ import Control.Exception (bracket) #else @@ -293,6 +294,14 @@ Just (w, bs') -> Just (w2c w, bs') {-# INLINE uncons #-} +-- | /O(n\/c)/ Extract the 'init' and 'last' of a ByteString, returning Nothing +-- if it is empty. +unsnoc :: ByteString -> Maybe (ByteString, Char) +unsnoc bs = case L.unsnoc bs of + Nothing -> Nothing + Just (bs', w) -> Just (bs', w2c w) +{-# INLINE unsnoc #-} + -- | /O(1)/ Extract the last element of a packed string, which must be non-empty. last :: ByteString -> Char last = w2c . L.last @@ -849,16 +858,16 @@ -- | Read an entire file /lazily/ into a 'ByteString'. readFile :: FilePath -> IO ByteString -readFile f = openFile f ReadMode >>= hGetContents +readFile f = openBinaryFile f ReadMode >>= hGetContents -- | Write a 'ByteString' to a file. writeFile :: FilePath -> ByteString -> IO () -writeFile f txt = bracket (openFile f WriteMode) hClose +writeFile f txt = bracket (openBinaryFile f WriteMode) hClose (\hdl -> hPut hdl txt) -- | Append a 'ByteString' to a file. appendFile :: FilePath -> ByteString -> IO () -appendFile f txt = bracket (openFile f AppendMode) hClose +appendFile f txt = bracket (openBinaryFile f AppendMode) hClose (\hdl -> hPut hdl txt) diff --git a/Data/ByteString/Unsafe.hs b/Data/ByteString/Unsafe.hs --- a/Data/ByteString/Unsafe.hs +++ b/Data/ByteString/Unsafe.hs @@ -23,6 +23,8 @@ -- * Unchecked access unsafeHead, -- :: ByteString -> Word8 unsafeTail, -- :: ByteString -> ByteString + unsafeInit, -- :: ByteString -> ByteString + unsafeLast, -- :: ByteString -> Word8 unsafeIndex, -- :: ByteString -> Int -> Word8 unsafeTake, -- :: Int -> ByteString -> ByteString unsafeDrop, -- :: Int -> ByteString -> ByteString @@ -36,6 +38,7 @@ unsafePackCString, -- :: CString -> IO ByteString unsafePackCStringLen, -- :: CStringLen -> IO ByteString unsafePackMallocCString,-- :: CString -> IO ByteString + unsafePackMallocCStringLen, -- :: CStringLen -> IO ByteString #if defined(__GLASGOW_HASKELL__) unsafePackAddress, -- :: Addr# -> IO ByteString @@ -109,6 +112,21 @@ unsafeTail (PS ps s l) = assert (l > 0) $ PS ps (s+1) (l-1) {-# INLINE unsafeTail #-} +-- | A variety of 'init' for non-empty ByteStrings. 'unsafeInit' omits the +-- check for the empty case. As with 'unsafeHead', the programmer must +-- provide a separate proof that the ByteString is non-empty. +unsafeInit :: ByteString -> ByteString +unsafeInit (PS ps s l) = assert (l > 0) $ PS ps s (l-1) +{-# INLINE unsafeInit #-} + +-- | A variety of 'last' for non-empty ByteStrings. 'unsafeLast' omits the +-- check for the empty case. As with 'unsafeHead', the programmer must +-- provide a separate proof that the ByteString is non-empty. +unsafeLast :: ByteString -> Word8 +unsafeLast (PS x s l) = assert (l > 0) $ + inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+l-1) +{-# INLINE unsafeLast #-} + -- | Unsafe 'ByteString' index (subscript) operator, starting from 0, returning a 'Word8' -- This omits the bounds check, which means there is an accompanying -- obligation on the programmer to ensure the bounds are checked in some @@ -262,6 +280,22 @@ fp <- newForeignPtr c_free_finalizer (castPtr cstr) len <- c_strlen cstr return $! PS fp 0 (fromIntegral len) + +-- | /O(n)/ Build a @ByteString@ from a malloced @CStringLen@. This +-- value will have a @free(3)@ finalizer associated to it. +-- +-- This funtion is /unsafe/. If the original @CString@ is later +-- modified, this change will be reflected in the resulting @ByteString@, +-- breaking referential transparency. +-- +-- This function is also unsafe if you call its finalizer twice, +-- which will result in a /double free/ error, or if you pass it +-- a CString not allocated with 'malloc'. +-- +unsafePackMallocCStringLen :: CStringLen -> IO ByteString +unsafePackMallocCStringLen (cstr, len) = do + fp <- newForeignPtr c_free_finalizer (castPtr cstr) + return $! PS fp 0 len -- --------------------------------------------------------------------- diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -17,12 +17,12 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Builder -import Data.ByteString.Lazy.Builder.ASCII -import Data.ByteString.Lazy.Builder.BasicEncoding - ( FixedEncoding, BoundedEncoding, (>$<) ) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as EI +import Data.ByteString.Builder +import Data.ByteString.Builder.ASCII +import Data.ByteString.Builder.Prim + ( FixedPrim, BoundedPrim, (>$<) ) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as PI import Foreign @@ -86,14 +86,14 @@ benchBInts :: String -> ([Int] -> Builder) -> Benchmark benchBInts name = benchB name intData --- | Benchmark a 'FixedEncoding'. Full inlining to enable specialization. +-- | Benchmark a 'FixedPrim'. Full inlining to enable specialization. {-# INLINE benchFE #-} -benchFE :: String -> FixedEncoding Int -> Benchmark -benchFE name = benchBE name . E.fromF +benchFE :: String -> FixedPrim Int -> Benchmark +benchFE name = benchBE name . P.liftFixedToBounded --- | Benchmark a 'BoundedEncoding'. Full inlining to enable specialization. +-- | Benchmark a 'BoundedPrim'. Full inlining to enable specialization. {-# INLINE benchBE #-} -benchBE :: String -> BoundedEncoding Int -> Benchmark +benchBE :: String -> BoundedPrim Int -> Benchmark benchBE name e = bench (name ++" (" ++ show nRepl ++ ")") $ benchIntEncodingB nRepl e @@ -101,18 +101,18 @@ -- we measure the speed of the encoding and not the speed of generating the -- values to be encoded. {-# INLINE benchIntEncodingB #-} -benchIntEncodingB :: Int -- ^ Maximal 'Int' to write - -> BoundedEncoding Int -- ^ 'BoundedEncoding' to execute - -> IO () -- ^ 'IO' action to benchmark +benchIntEncodingB :: Int -- ^ Maximal 'Int' to write + -> BoundedPrim Int -- ^ 'BoundedPrim' to execute + -> IO () -- ^ 'IO' action to benchmark benchIntEncodingB n0 w | n0 <= 0 = return () | otherwise = do - fpbuf <- mallocForeignPtrBytes (n0 * EI.sizeBound w) + fpbuf <- mallocForeignPtrBytes (n0 * PI.sizeBound w) withForeignPtr fpbuf (loop n0) >> return () where loop !n !op | n <= 0 = return op - | otherwise = EI.runB w n op >>= loop (n - 1) + | otherwise = PI.runB w n op >>= loop (n - 1) @@ -133,111 +133,111 @@ mapM_ putStrLn sanityCheckInfo putStrLn "" Criterion.Main.defaultMain - [ bgroup "Data.ByteString.Lazy.Builder" + [ bgroup "Data.ByteString.Builder" [ bgroup "Encoding wrappers" [ benchBInts "foldMap word8" $ foldMap (word8 . fromIntegral) - , benchBInts "encodeListWithF word8" $ - E.encodeListWithF (fromIntegral >$< E.word8) - , benchB "encodeUnfoldrWithF word8" nRepl $ - E.encodeUnfoldrWithF (fromIntegral >$< E.word8) countToZero - , benchB "encodeByteStringWithF word8" byteStringData $ - E.encodeByteStringWithF E.word8 - , benchB "encodeLazyByteStringWithF word8" lazyByteStringData $ - E.encodeLazyByteStringWithF E.word8 + , benchBInts "primMapListFixed word8" $ + P.primMapListFixed (fromIntegral >$< P.word8) + , benchB "primUnfoldrFixed word8" nRepl $ + P.primUnfoldrFixed (fromIntegral >$< P.word8) countToZero + , benchB "primMapByteStringFixed word8" byteStringData $ + P.primMapByteStringFixed P.word8 + , benchB "primMapLazyByteStringFixed word8" lazyByteStringData $ + P.primMapLazyByteStringFixed P.word8 ] , bgroup "Non-bounded encodings" [ benchB "foldMap floatDec" floatData $ foldMap floatDec , benchB "foldMap doubleDec" doubleData $ foldMap doubleDec , benchB "foldMap integerDec" integerData $ foldMap integerDec - , benchB "byteStringHexFixed" byteStringData $ byteStringHexFixed - , benchB "lazyByteStringHexFixed" lazyByteStringData $ lazyByteStringHexFixed + , benchB "byteStringHex" byteStringData $ byteStringHex + , benchB "lazyByteStringHex" lazyByteStringData $ lazyByteStringHex ] ] - , bgroup "Data.ByteString.Lazy.Builder.BasicEncoding" - [ benchFE "char7" $ toEnum >$< E.char7 - , benchFE "char8" $ toEnum >$< E.char8 - , benchBE "charUtf8" $ toEnum >$< E.charUtf8 + , bgroup "Data.ByteString.Builder.Prim" + [ benchFE "char7" $ toEnum >$< P.char7 + , benchFE "char8" $ toEnum >$< P.char8 + , benchBE "charUtf8" $ toEnum >$< P.charUtf8 -- binary encoding - , benchFE "int8" $ fromIntegral >$< E.int8 - , benchFE "word8" $ fromIntegral >$< E.word8 + , benchFE "int8" $ fromIntegral >$< P.int8 + , benchFE "word8" $ fromIntegral >$< P.word8 -- big-endian - , benchFE "int16BE" $ fromIntegral >$< E.int16BE - , benchFE "int32BE" $ fromIntegral >$< E.int32BE - , benchFE "int64BE" $ fromIntegral >$< E.int64BE + , benchFE "int16BE" $ fromIntegral >$< P.int16BE + , benchFE "int32BE" $ fromIntegral >$< P.int32BE + , benchFE "int64BE" $ fromIntegral >$< P.int64BE - , benchFE "word16BE" $ fromIntegral >$< E.word16BE - , benchFE "word32BE" $ fromIntegral >$< E.word32BE - , benchFE "word64BE" $ fromIntegral >$< E.word64BE + , benchFE "word16BE" $ fromIntegral >$< P.word16BE + , benchFE "word32BE" $ fromIntegral >$< P.word32BE + , benchFE "word64BE" $ fromIntegral >$< P.word64BE - , benchFE "floatBE" $ fromIntegral >$< E.floatBE - , benchFE "doubleBE" $ fromIntegral >$< E.doubleBE + , benchFE "floatBE" $ fromIntegral >$< P.floatBE + , benchFE "doubleBE" $ fromIntegral >$< P.doubleBE -- little-endian - , benchFE "int16LE" $ fromIntegral >$< E.int16LE - , benchFE "int32LE" $ fromIntegral >$< E.int32LE - , benchFE "int64LE" $ fromIntegral >$< E.int64LE + , benchFE "int16LE" $ fromIntegral >$< P.int16LE + , benchFE "int32LE" $ fromIntegral >$< P.int32LE + , benchFE "int64LE" $ fromIntegral >$< P.int64LE - , benchFE "word16LE" $ fromIntegral >$< E.word16LE - , benchFE "word32LE" $ fromIntegral >$< E.word32LE - , benchFE "word64LE" $ fromIntegral >$< E.word64LE + , benchFE "word16LE" $ fromIntegral >$< P.word16LE + , benchFE "word32LE" $ fromIntegral >$< P.word32LE + , benchFE "word64LE" $ fromIntegral >$< P.word64LE - , benchFE "floatLE" $ fromIntegral >$< E.floatLE - , benchFE "doubleLE" $ fromIntegral >$< E.doubleLE + , benchFE "floatLE" $ fromIntegral >$< P.floatLE + , benchFE "doubleLE" $ fromIntegral >$< P.doubleLE -- host-dependent - , benchFE "int16Host" $ fromIntegral >$< E.int16Host - , benchFE "int32Host" $ fromIntegral >$< E.int32Host - , benchFE "int64Host" $ fromIntegral >$< E.int64Host - , benchFE "intHost" $ fromIntegral >$< E.intHost + , benchFE "int16Host" $ fromIntegral >$< P.int16Host + , benchFE "int32Host" $ fromIntegral >$< P.int32Host + , benchFE "int64Host" $ fromIntegral >$< P.int64Host + , benchFE "intHost" $ fromIntegral >$< P.intHost - , benchFE "word16Host" $ fromIntegral >$< E.word16Host - , benchFE "word32Host" $ fromIntegral >$< E.word32Host - , benchFE "word64Host" $ fromIntegral >$< E.word64Host - , benchFE "wordHost" $ fromIntegral >$< E.wordHost + , benchFE "word16Host" $ fromIntegral >$< P.word16Host + , benchFE "word32Host" $ fromIntegral >$< P.word32Host + , benchFE "word64Host" $ fromIntegral >$< P.word64Host + , benchFE "wordHost" $ fromIntegral >$< P.wordHost - , benchFE "floatHost" $ fromIntegral >$< E.floatHost - , benchFE "doubleHost" $ fromIntegral >$< E.doubleHost + , benchFE "floatHost" $ fromIntegral >$< P.floatHost + , benchFE "doubleHost" $ fromIntegral >$< P.doubleHost ] - , bgroup "Data.ByteString.Lazy.Builder.BoundedEncoding.ASCII" + , bgroup "Data.ByteString.Builder.Prim.ASCII" [ -- decimal number - benchBE "int8Dec" $ fromIntegral >$< E.int8Dec - , benchBE "int16Dec" $ fromIntegral >$< E.int16Dec - , benchBE "int32Dec" $ fromIntegral >$< E.int32Dec - , benchBE "int64Dec" $ fromIntegral >$< E.int64Dec - , benchBE "intDec" $ fromIntegral >$< E.intDec + benchBE "int8Dec" $ fromIntegral >$< P.int8Dec + , benchBE "int16Dec" $ fromIntegral >$< P.int16Dec + , benchBE "int32Dec" $ fromIntegral >$< P.int32Dec + , benchBE "int64Dec" $ fromIntegral >$< P.int64Dec + , benchBE "intDec" $ fromIntegral >$< P.intDec - , benchBE "word8Dec" $ fromIntegral >$< E.word8Dec - , benchBE "word16Dec" $ fromIntegral >$< E.word16Dec - , benchBE "word32Dec" $ fromIntegral >$< E.word32Dec - , benchBE "word64Dec" $ fromIntegral >$< E.word64Dec - , benchBE "wordDec" $ fromIntegral >$< E.wordDec + , benchBE "word8Dec" $ fromIntegral >$< P.word8Dec + , benchBE "word16Dec" $ fromIntegral >$< P.word16Dec + , benchBE "word32Dec" $ fromIntegral >$< P.word32Dec + , benchBE "word64Dec" $ fromIntegral >$< P.word64Dec + , benchBE "wordDec" $ fromIntegral >$< P.wordDec -- hexadecimal number - , benchBE "word8Hex" $ fromIntegral >$< E.word8Hex - , benchBE "word16Hex" $ fromIntegral >$< E.word16Hex - , benchBE "word32Hex" $ fromIntegral >$< E.word32Hex - , benchBE "word64Hex" $ fromIntegral >$< E.word64Hex - , benchBE "wordHex" $ fromIntegral >$< E.wordHex + , benchBE "word8Hex" $ fromIntegral >$< P.word8Hex + , benchBE "word16Hex" $ fromIntegral >$< P.word16Hex + , benchBE "word32Hex" $ fromIntegral >$< P.word32Hex + , benchBE "word64Hex" $ fromIntegral >$< P.word64Hex + , benchBE "wordHex" $ fromIntegral >$< P.wordHex -- fixed-width hexadecimal numbers - , benchFE "int8HexFixed" $ fromIntegral >$< E.int8HexFixed - , benchFE "int16HexFixed" $ fromIntegral >$< E.int16HexFixed - , benchFE "int32HexFixed" $ fromIntegral >$< E.int32HexFixed - , benchFE "int64HexFixed" $ fromIntegral >$< E.int64HexFixed + , benchFE "int8HexFixed" $ fromIntegral >$< P.int8HexFixed + , benchFE "int16HexFixed" $ fromIntegral >$< P.int16HexFixed + , benchFE "int32HexFixed" $ fromIntegral >$< P.int32HexFixed + , benchFE "int64HexFixed" $ fromIntegral >$< P.int64HexFixed - , benchFE "word8HexFixed" $ fromIntegral >$< E.word8HexFixed - , benchFE "word16HexFixed" $ fromIntegral >$< E.word16HexFixed - , benchFE "word32HexFixed" $ fromIntegral >$< E.word32HexFixed - , benchFE "word64HexFixed" $ fromIntegral >$< E.word64HexFixed + , benchFE "word8HexFixed" $ fromIntegral >$< P.word8HexFixed + , benchFE "word16HexFixed" $ fromIntegral >$< P.word16HexFixed + , benchFE "word32HexFixed" $ fromIntegral >$< P.word32HexFixed + , benchFE "word64HexFixed" $ fromIntegral >$< P.word64HexFixed - , benchFE "floatHexFixed" $ fromIntegral >$< E.floatHexFixed - , benchFE "doubleHexFixed" $ fromIntegral >$< E.doubleHexFixed + , benchFE "floatHexFixed" $ fromIntegral >$< P.floatHexFixed + , benchFE "doubleHexFixed" $ fromIntegral >$< P.doubleHexFixed ] ] diff --git a/bench/BoundsCheckFusion.hs b/bench/BoundsCheckFusion.hs --- a/bench/BoundsCheckFusion.hs +++ b/bench/BoundsCheckFusion.hs @@ -18,13 +18,13 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Builder -import Data.ByteString.Lazy.Builder.Extras -import Data.ByteString.Lazy.Builder.BasicEncoding - ( FixedEncoding, BoundedEncoding, (>$<), (>*<) ) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E -import qualified Data.ByteString.Lazy.Builder.Internal as I -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import Data.ByteString.Builder.Prim + ( FixedPrim, BoundedPrim, (>$<), (>*<) ) +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Internal as I +import qualified Data.ByteString.Builder.Prim.Internal as I import Foreign @@ -100,28 +100,28 @@ foldMap (\x -> intHost x `mappend` (intHost x `mappend` stringUtf8 "s")) , benchBInts "foldMap [manually fused, left-assoc]" $ - foldMap (\x -> stringUtf8 "s" `mappend` E.encodeWithB (E.fromF $ E.intHost >*< E.intHost) (x, x)) + foldMap (\x -> stringUtf8 "s" `mappend` P.primBounded (P.liftFixedToBounded $ P.intHost >*< P.intHost) (x, x)) , benchBInts "foldMap [manually fused, right-assoc]" $ - foldMap (\x -> E.encodeWithB (E.fromF $ E.intHost >*< E.intHost) (x, x) `mappend` stringUtf8 "s") + foldMap (\x -> P.primBounded (P.liftFixedToBounded $ P.intHost >*< P.intHost) (x, x) `mappend` stringUtf8 "s") -- , benchBInts "encodeListWithF intHost" $ - -- E.encodeListWithF (fromIntegral >$< E.intHost) + -- P.encodeListWithF (fromIntegral >$< P.intHost) ] ] {-# RULES "append/encodeWithB" forall w1 w2 x1 x2. - I.append (E.encodeWithB w1 x1) (E.encodeWithB w2 x2) - = E.encodeWithB (E.pairB w1 w2) (x1, x2) + I.append (P.primBounded w1 x1) (P.primBounded w2 x2) + = P.primBounded (I.pairB w1 w2) (x1, x2) "append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b. - I.append (E.encodeWithB w1 x1) (I.append (E.encodeWithB w2 x2) b) - = I.append (E.encodeWithB (E.pairB w1 w2) (x1, x2)) b + I.append (P.primBounded w1 x1) (I.append (P.primBounded w2 x2) b) + = I.append (P.primBounded (I.pairB w1 w2) (x1, x2)) b "append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b. - I.append (I.append b (E.encodeWithB w1 x1)) (E.encodeWithB w2 x2) - = I.append b (E.encodeWithB (E.pairB w1 w2) (x1, x2)) + I.append (I.append b (P.primBounded w1 x1)) (P.primBounded w2 x2) + = I.append b (P.primBounded (I.pairB w1 w2) (x1, x2)) #-} diff --git a/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -1,5 +1,5 @@ Name: bytestring -Version: 0.10.0.2 +Version: 0.10.2.0 Synopsis: Fast, compact, strict and lazy byte strings with a list interface Description: An efficient compact, immutable byte string type (both strict and lazy) @@ -71,23 +71,26 @@ Data.ByteString.Lazy.Char8 Data.ByteString.Lazy.Internal + Data.ByteString.Builder + Data.ByteString.Builder.Extra + Data.ByteString.Builder.Prim + + -- perhaps only exposed temporarily + Data.ByteString.Builder.Internal + Data.ByteString.Builder.Prim.Internal + + -- sigh, we decided to rename shortly after making + -- an initial release, so these are here for compat Data.ByteString.Lazy.Builder Data.ByteString.Lazy.Builder.Extras Data.ByteString.Lazy.Builder.ASCII - other-modules: - -- these three modules should be exposed in a future - -- release once we're confident the API is stable. - Data.ByteString.Lazy.Builder.Internal - Data.ByteString.Lazy.Builder.BasicEncoding - Data.ByteString.Lazy.Builder.BasicEncoding.Extras - Data.ByteString.Lazy.Builder.BasicEncoding.Internal - - Data.ByteString.Lazy.Builder.BasicEncoding.Binary - Data.ByteString.Lazy.Builder.BasicEncoding.ASCII - Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating - Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts - Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 + Data.ByteString.Builder.ASCII + Data.ByteString.Builder.Prim.Binary + Data.ByteString.Builder.Prim.ASCII + Data.ByteString.Builder.Prim.Internal.Floating + Data.ByteString.Builder.Prim.Internal.UncheckedShifts + Data.ByteString.Builder.Prim.Internal.Base16 extensions: CPP, ForeignFunctionInterface, @@ -139,10 +142,10 @@ type: exitcode-stdio-1.0 hs-source-dirs: . tests tests/builder main-is: TestSuite.hs - other-modules: Data.ByteString.Lazy.Builder.Tests - Data.ByteString.Lazy.Builder.BasicEncoding.Tests - Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils - Data.ByteString.Lazy.Builder.BasicEncoding.Extras + other-modules: Data.ByteString.Builder.Tests + Data.ByteString.Builder.Prim.Tests + Data.ByteString.Builder.Prim.TestUtils + Data.ByteString.Builder.Prim.Extra TestFramework build-depends: base, ghc-prim, @@ -150,7 +153,7 @@ QuickCheck >= 2.4 && < 3, byteorder == 1.0.*, dlist == 0.5.*, - directory, + directory >= 1.0 && < 1.2, mtl >= 2.0 && < 2.2 ghc-options: -Wall -fwarn-tabs diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -76,6 +76,7 @@ prop_consCC = D.cons `eq2` C.cons prop_consCC' = D.cons' `eq2` C.cons prop_unconsCC = D.uncons `eq1` C.uncons +prop_unsnocCC = D.unsnoc `eq1` C.unsnoc prop_countCC = D.count `eq2` ((toInt64 .) . C.count) prop_dropCC = (D.drop . toInt64) `eq2` C.drop prop_dropWhileCC = D.dropWhile `eq2` C.dropWhile @@ -159,6 +160,7 @@ prop_consBP = L.cons `eq2` P.cons prop_consBP' = L.cons' `eq2` P.cons prop_unconsBP = L.uncons `eq1` P.uncons +prop_unsnocBP = L.unsnoc `eq1` P.unsnoc prop_countBP = L.count `eq2` ((toInt64 .) . P.count) prop_dropBP = (L.drop. toInt64) `eq2` P.drop prop_dropWhileBP = L.dropWhile `eq2` P.dropWhile @@ -918,10 +920,14 @@ prop_tail1BB xs = (not (null xs)) ==> tail xs == (P.unpack . P.unsafeTail. P.pack) xs prop_lastBB xs = (not (null xs)) ==> last xs == (P.last . P.pack) xs +prop_last1BB xs = (not (null xs)) ==> last xs == (P.unsafeLast . P.pack) xs prop_initBB xs = (not (null xs)) ==> init xs == (P.unpack . P.init . P.pack) xs +prop_init1BB xs = + (not (null xs)) ==> + init xs == (P.unpack . P.unsafeInit . P.pack) xs -- prop_null xs = (null xs) ==> null xs == (nullPS (pack xs)) @@ -1902,6 +1908,7 @@ , testProperty "prop_consCC" prop_consCC , testProperty "prop_consCC'" prop_consCC' , testProperty "prop_unconsCC" prop_unconsCC + , testProperty "prop_unsnocCC" prop_unsnocCC , testProperty "prop_countCC" prop_countCC , testProperty "prop_dropCC" prop_dropCC , testProperty "prop_dropWhileCC" prop_dropWhileCC @@ -1954,6 +1961,7 @@ , testProperty "cons" prop_consBP , testProperty "cons'" prop_consBP' , testProperty "uncons" prop_unconsBP + , testProperty "unsnoc" prop_unsnocBP , testProperty "eq" prop_eqBP , testProperty "filter" prop_filterBP , testProperty "find" prop_findBP @@ -2136,7 +2144,9 @@ , testProperty "tail" prop_tailBB , testProperty "tail 1" prop_tail1BB , testProperty "last" prop_lastBB + , testProperty "last 1" prop_last1BB , testProperty "init" prop_initBB + , testProperty "init 1" prop_init1BB , testProperty "append 1" prop_append1BB , testProperty "append 2" prop_append2BB , testProperty "append 3" prop_append3BB diff --git a/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing utilities for comparing +-- for an example on how to use the functions provided here. +-- +module Data.ByteString.Builder.Prim.TestUtils ( + + -- * Showing + evalF + , evalB + + , showF + , showB + + -- * Testing 'FixedPrim's + , testF + , testBoundedF + + , testFixedBoundF + + , compareImpls + + -- * Testing 'BoundedPrim's + , testBoundedB + + -- * Encoding reference implementations + + , charUtf8_list + , char8_list + + -- ** ASCII-based encodings + , encodeASCII + , encodeForcedASCII + , char7_list + , dec_list + , hex_list + , wordHexFixed_list + , int8HexFixed_list + , int16HexFixed_list + , int32HexFixed_list + , int64HexFixed_list + , floatHexFixed_list + , doubleHexFixed_list + + -- ** Binary + , parseVar + + , bigEndian_list + , littleEndian_list + , hostEndian_list + , float_list + , double_list + , coerceFloatToWord32 + , coerceDoubleToWord64 + + ) where + +import Control.Arrow (first) + +import Data.ByteString.Builder.Prim + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Builder.Prim.Internal as I + +import Data.Char (chr, ord) + +import Numeric (showHex) + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + +import System.ByteOrder +import Unsafe.Coerce (unsafeCoerce) + +import TestFramework +import Test.QuickCheck (Arbitrary(..)) + +-- Helper functions +------------------- + +-- | Quickcheck test that includes a check that the property holds on the +-- bounds of a bounded value. +testBoundedProperty :: forall a. (Arbitrary a, Show a, Bounded a) + => String -> (a -> Bool) -> Test +testBoundedProperty name p = testGroup name + [ testProperty "arbitrary" p + , testCase "bounds" $ p (minBound :: a) + && p (maxBound :: a) + ] + +-- | Quote a 'String' nicely. +quote :: String -> String +quote cs = '`' : cs ++ "'" + +-- | Quote a @[Word8]@ list as as 'String'. +quoteWord8s :: [Word8] -> String +quoteWord8s = quote . map (chr . fromIntegral) + + +------------------------------------------------------------------------------ +-- Testing encodings +------------------------------------------------------------------------------ + +-- | /For testing use only./ Evaluate a 'FixedPrim' on a given value. +evalF :: FixedPrim a -> a -> [Word8] +evalF fe = S.unpack . S.unsafeCreate (I.size fe) . I.runF fe + +-- | /For testing use only./ Evaluate a 'BoundedPrim' on a given value. +evalB :: BoundedPrim a -> a -> [Word8] +evalB be x = S.unpack $ unsafePerformIO $ + S.createAndTrim (I.sizeBound be) $ \op -> do + op' <- I.runB be x op + return (op' `minusPtr` op) + +-- | /For testing use only./ Show the result of a 'FixedPrim' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showF :: FixedPrim a -> a -> String +showF fe = map (chr . fromIntegral) . evalF fe + +-- | /For testing use only./ Show the result of a 'BoundedPrim' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showB :: BoundedPrim a -> a -> String +showB be = map (chr . fromIntegral) . evalB be + + +-- FixedPrim +---------------- + +-- TODO: Port code that checks for low-level properties of basic encodings (no +-- overwrites, all bytes written, etc.) from old 'system-io-write' library + +-- | Test a 'FixedPrim' against a reference implementation. +testF :: (Arbitrary a, Show a) + => String + -> (a -> [Word8]) + -> FixedPrim a + -> Test +testF name ref fe = + testProperty name prop + where + prop x + | y == y' = True + | otherwise = error $ unlines $ + [ "testF: results disagree for " ++ quote (show x) + , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y + , " reference: " ++ show y'++ " " ++ quoteWord8s y' + ] + where + y = evalF fe x + y' = ref x + +-- | Test a 'FixedPrim' of a bounded value against a reference implementation +-- and ensure that the bounds are always included as testcases. +testBoundedF :: (Arbitrary a, Bounded a, Show a) + => String + -> (a -> [Word8]) + -> FixedPrim a + -> Test +testBoundedF name ref fe = + testBoundedProperty name $ \x -> evalF fe x == ref x + +-- FixedPrim derived from a bound on a given value. + +testFixedBoundF :: (Arbitrary a, Show a, Integral a) + => String + -> (a -> a -> [Word8]) + -> (a -> FixedPrim a) + -> Test +testFixedBoundF name ref bfe = + testProperty name prop + where + prop (b, x0) + | y == y' = True + | otherwise = error $ unlines $ + [ "testF: results disagree for " ++ quote (show (b, x)) + , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y + , " reference: " ++ show y'++ " " ++ quoteWord8s y' + ] + where + x | b == 0 = 0 + | otherwise = x0 `mod` b + y = evalF (bfe b) x + y' = ref b x + + +-- BoundedPrim +------------------ + +-- | Test a 'BoundedPrim' of a bounded value against a reference implementation +-- and ensure that the bounds are always included as testcases. +testBoundedB :: (Arbitrary a, Bounded a, Show a) + => String + -> (a -> [Word8]) + -> BoundedPrim a + -> Test +testBoundedB name ref fe = + testBoundedProperty name check + where + check x + | y == y' = True + | otherwise = error $ unlines $ + [ "testBoundedB: results disagree for " ++ quote (show x) + , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y + , " reference: " ++ show y'++ " " ++ quoteWord8s y' + ] + where + y = evalB fe x + y' = ref x + +-- | Compare two implementations of a function. +compareImpls :: (Arbitrary a, Show a, Show b, Eq b) + => TestName -> (a -> b) -> (a -> b) -> Test +compareImpls name f1 f2 = + testProperty name check + where + check x + | y1 == y2 = True + | otherwise = error $ unlines $ + [ "compareImpls: results disagree for " ++ quote (show x) + , " f1: " ++ show y1 + , " f2: " ++ show y2 + ] + where + y1 = f1 x + y2 = f2 x + + + +------------------------------------------------------------------------------ +-- Encoding reference implementations +------------------------------------------------------------------------------ + +-- | Char8 encoding: truncate Unicode codepoint to 8-bits. +char8_list :: Char -> [Word8] +char8_list = return . fromIntegral . ord + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +-- +-- Copied from 'utf8-string-0.3.6' to make tests self-contained. +-- Copyright (c) 2007, Galois Inc. All rights reserved. +-- +charUtf8_list :: Char -> [Word8] +charUtf8_list = + map fromIntegral . encode . ord + where + encode oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) + , 0x80 + oc .&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `shiftR` 18) + , 0x80 + ((oc `shiftR` 12) .&. 0x3f) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + +-- ASCII-based encodings +------------------------ + +-- | Encode a 'String' of only ASCII characters using the ASCII encoding. +encodeASCII :: String -> [Word8] +encodeASCII = + map encode + where + encode c + | c < '\x7f' = fromIntegral $ ord c + | otherwise = error $ "encodeASCII: non-ASCII character '" ++ [c] ++ "'" + +-- | Encode an arbitrary 'String' by truncating its characters to the least +-- significant 7-bits. +encodeForcedASCII :: String -> [Word8] +encodeForcedASCII = map ((.&. 0x7f) . fromIntegral . ord) + +char7_list :: Char -> [Word8] +char7_list = encodeForcedASCII . return + +dec_list :: Show a => a -> [Word8] +dec_list = encodeASCII . show + +hex_list :: (Integral a, Show a) => a -> [Word8] +hex_list = encodeASCII . (\x -> showHex x "") + +wordHexFixed_list :: (Storable a, Integral a, Show a) => a -> [Word8] +wordHexFixed_list x = + encodeASCII $ pad (2 * sizeOf x) $ showHex x "" + where + pad n cs = replicate (n - length cs) '0' ++ cs + +int8HexFixed_list :: Int8 -> [Word8] +int8HexFixed_list = wordHexFixed_list . (fromIntegral :: Int8 -> Word8 ) + +int16HexFixed_list :: Int16 -> [Word8] +int16HexFixed_list = wordHexFixed_list . (fromIntegral :: Int16 -> Word16) + +int32HexFixed_list :: Int32 -> [Word8] +int32HexFixed_list = wordHexFixed_list . (fromIntegral :: Int32 -> Word32) + +int64HexFixed_list :: Int64 -> [Word8] +int64HexFixed_list = wordHexFixed_list . (fromIntegral :: Int64 -> Word64) + +floatHexFixed_list :: Float -> [Word8] +floatHexFixed_list = float_list wordHexFixed_list + +doubleHexFixed_list :: Double -> [Word8] +doubleHexFixed_list = double_list wordHexFixed_list + +-- Binary +--------- + +bigEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] +bigEndian_list = reverse . littleEndian_list + +littleEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] +littleEndian_list x = + map (fromIntegral . (x `shiftR`) . (8*)) $ [0..sizeOf x - 1] + +hostEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] +hostEndian_list = case byteOrder of + LittleEndian -> littleEndian_list + BigEndian -> bigEndian_list + _ -> error $ + "bounded-encoding: unsupported byteorder '" ++ show byteOrder ++ "'" + + +float_list :: (Word32 -> [Word8]) -> Float -> [Word8] +float_list f = f . coerceFloatToWord32 + +double_list :: (Word64 -> [Word8]) -> Double -> [Word8] +double_list f = f . coerceDoubleToWord64 + +-- Note that the following use of unsafeCoerce is not guaranteed to be +-- safe on GHC 7.0 and less. The reason is probably the following ticket: +-- +-- http://hackage.haskell.org/trac/ghc/ticket/4092 +-- +-- However, that only applies if the value is loaded in a register. We +-- avoid this by coercing only boxed values and ensuring that they +-- remain boxed using a NOINLINE pragma. +-- + +-- | Super unsafe coerce a 'Float' to a 'Word32'. We have to explicitly mask +-- out the higher bits in case we are working on a 64-bit machine. +{-# NOINLINE coerceFloatToWord32 #-} +coerceFloatToWord32 :: Float -> Word32 +coerceFloatToWord32 = (.&. maxBound) . unsafeCoerce + +-- | Super unsafe coerce a 'Double' to a 'Word64'. Currently, there are no +-- > 64 bit machines supported by GHC. But we just play it safe. +{-# NOINLINE coerceDoubleToWord64 #-} +coerceDoubleToWord64 :: Double -> Word64 +coerceDoubleToWord64 = (.&. maxBound) . unsafeCoerce + +-- | Parse a variable length encoding +parseVar :: (Num a, Bits a) => [Word8] -> (a, [Word8]) +parseVar = + go + where + go [] = error "parseVar: unterminated variable length int" + go (w:ws) + | w .&. 0x80 == 0 = (fromIntegral w, ws) + | otherwise = first add (go ws) + where + add x = (x `shiftL` 7) .|. (fromIntegral w .&. 0x7f) + + diff --git a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing all encodings provided by this library. + +module Data.ByteString.Builder.Prim.Tests (tests) where + +import Control.Arrow (first) + +import Data.Char (ord) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Builder +import qualified Data.ByteString.Builder.Prim as BP +import qualified Data.ByteString.Builder.Prim.Extra as BP +import Data.ByteString.Builder.Prim.TestUtils + +import Numeric (showHex) + +import Foreign + +import TestFramework +import Test.QuickCheck (Arbitrary) + + +tests :: [Test] +tests = concat [ testsBinary, testsASCII, testsChar8, testsUtf8 + , testsCombinatorsB ] + + +------------------------------------------------------------------------------ +-- Binary +------------------------------------------------------------------------------ + +testsBinary :: [Test] +testsBinary = + [ testBoundedF "word8" bigEndian_list BP.word8 + , testBoundedF "int8" bigEndian_list BP.int8 + + -- big-endian + , testBoundedF "int16BE" bigEndian_list BP.int16BE + , testBoundedF "int32BE" bigEndian_list BP.int32BE + , testBoundedF "int64BE" bigEndian_list BP.int64BE + + , testBoundedF "word16BE" bigEndian_list BP.word16BE + , testBoundedF "word32BE" bigEndian_list BP.word32BE + , testBoundedF "word64BE" bigEndian_list BP.word64BE + + , testF "floatLE" (float_list littleEndian_list) BP.floatLE + , testF "doubleLE" (double_list littleEndian_list) BP.doubleLE + + -- little-endian + , testBoundedF "int16LE" littleEndian_list BP.int16LE + , testBoundedF "int32LE" littleEndian_list BP.int32LE + , testBoundedF "int64LE" littleEndian_list BP.int64LE + + , testBoundedF "word16LE" littleEndian_list BP.word16LE + , testBoundedF "word32LE" littleEndian_list BP.word32LE + , testBoundedF "word64LE" littleEndian_list BP.word64LE + + , testF "floatBE" (float_list bigEndian_list) BP.floatBE + , testF "doubleBE" (double_list bigEndian_list) BP.doubleBE + + -- host dependent + , testBoundedF "int16Host" hostEndian_list BP.int16Host + , testBoundedF "int32Host" hostEndian_list BP.int32Host + , testBoundedF "int64Host" hostEndian_list BP.int64Host + , testBoundedF "intHost" hostEndian_list BP.intHost + + , testBoundedF "word16Host" hostEndian_list BP.word16Host + , testBoundedF "word32Host" hostEndian_list BP.word32Host + , testBoundedF "word64Host" hostEndian_list BP.word64Host + , testBoundedF "wordHost" hostEndian_list BP.wordHost + + , testF "floatHost" (float_list hostEndian_list) BP.floatHost + , testF "doubleHost" (double_list hostEndian_list) BP.doubleHost + + , testBoundedB "word8Var" genVar_list BP.word8Var + , testBoundedB "word16Var" genVar_list BP.word16Var + , testBoundedB "word32Var" genVar_list BP.word32Var + , testBoundedB "word64Var" genVar_list BP.word64Var + , testBoundedB "wordVar" genVar_list BP.wordVar + + , testBoundedB "int8Var" int8Var_list BP.int8Var + , testBoundedB "int16Var" int16Var_list BP.int16Var + , testBoundedB "int32Var" int32Var_list BP.int32Var + , testBoundedB "int64Var" int64Var_list BP.int64Var + , testBoundedB "intVar" intVar_list BP.intVar + + , testBoundedB "int8VarSigned" (int8Var_list . zigZag) BP.int8VarSigned + , testBoundedB "int16VarSigned" (int16Var_list . zigZag) BP.int16VarSigned + , testBoundedB "int32VarSigned" (int32Var_list . zigZag) BP.int32VarSigned + , testBoundedB "int64VarSigned" (int64Var_list . zigZag) BP.int64VarSigned + , testBoundedB "intVarSigned" (intVar_list . zigZag) BP.intVarSigned + + , testGroup "parseable" + [ prop_zigZag_parseable "int8VarSigned" unZigZagInt8 BP.int8VarSigned + , prop_zigZag_parseable "int16VarSigned" unZigZagInt16 BP.int16VarSigned + , prop_zigZag_parseable "int32VarSigned" unZigZagInt32 BP.int32VarSigned + , prop_zigZag_parseable "int64VarSigned" unZigZagInt64 BP.int64VarSigned + , prop_zigZag_parseable "intVarSigned" unZigZagInt BP.intVarSigned + ] + + , testFixedBoundF "wordVarFixedBound" wordVarFixedBound_list BP.wordVarFixedBound + , testFixedBoundF "word64VarFixedBound" word64VarFixedBound_list BP.word64VarFixedBound + + ] + + +-- Variable length encodings +---------------------------- + +-- | Variable length encoding. +genVar_list :: (Ord a, Num a, Bits a, Integral a) => a -> [Word8] +genVar_list x + | x <= 0x7f = sevenBits : [] + | otherwise = (sevenBits .|. 0x80) : genVar_list (x `shiftR` 7) + where + sevenBits = fromIntegral x .&. 0x7f + +int8Var_list :: Int8 -> [Word8] +int8Var_list = genVar_list . (fromIntegral :: Int8 -> Word8) + +int16Var_list :: Int16 -> [Word8] +int16Var_list = genVar_list . (fromIntegral :: Int16 -> Word16) + +int32Var_list :: Int32 -> [Word8] +int32Var_list = genVar_list . (fromIntegral :: Int32 -> Word32) + +int64Var_list :: Int64 -> [Word8] +int64Var_list = genVar_list . (fromIntegral :: Int64 -> Word64) + +intVar_list :: Int -> [Word8] +intVar_list = genVar_list . (fromIntegral :: Int -> Word) + + +-- | The so-called \"zig-zag\" encoding from Google's protocol buffers. +-- It maps integers of small magnitude to naturals of small +-- magnitude by encoding negative integers as odd naturals and positive +-- integers as even naturals. +-- +-- For example: @0 -> 0, -1 -> 1, 1 -> 2, -2 -> 3, 2 -> 4, ...@ +-- +-- PRE: 'a' must be a signed integer type. +zigZag :: (Storable a, Bits a) => a -> a +zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1)) + + +-- | Reversing the zigZag encoding. +-- +-- PRE: 'a' must be an unsigned integer type. +-- +-- forall x. fromIntegral x == +-- unZigZag ((fromIntegral :: IntX -> WordX) (zigZag x)) +-- +unZigZag :: (Storable a, Num a, Bits a) => a -> a +unZigZag x = (x `shiftR` 1) `xor` negate (x .&. 1) + +unZigZagInt8 :: Int8 -> Int8 +unZigZagInt8 = (fromIntegral :: Word8 -> Int8) . unZigZag . fromIntegral + +unZigZagInt16 :: Int16 -> Int16 +unZigZagInt16 = (fromIntegral :: Word16 -> Int16) . unZigZag . fromIntegral + +unZigZagInt32 :: Int32 -> Int32 +unZigZagInt32 = (fromIntegral :: Word32 -> Int32) . unZigZag . fromIntegral + +unZigZagInt64 :: Int64 -> Int64 +unZigZagInt64 = (fromIntegral :: Word64 -> Int64) . unZigZag . fromIntegral + +unZigZagInt :: Int -> Int +unZigZagInt = (fromIntegral :: Word -> Int) . unZigZag . fromIntegral + +-- | Check that the 'intVarSigned' encodings are parseable. +prop_zigZag_parseable :: (Arbitrary t, Num b, Bits b, Show t, Eq t) + => String -> (b -> t) -> BP.BoundedPrim t -> Test +prop_zigZag_parseable name unZig be = + compareImpls name (\x -> (x, [])) (first unZig . parseVar . evalB be) + +-- | Variable length encoding to a fixed number of bytes (pad / truncate). +genVarFixedBound_list :: (Ord a, Num a, Bits a, Integral a) + => Int + -> a -> [Word8] +genVarFixedBound_list n x + | n <= 1 = sevenBits : [] + | otherwise = (sevenBits .|. 0x80) : genVarFixedBound_list (n - 1) (x `shiftR` 7) + where + sevenBits = fromIntegral x .&. 0x7f + +wordVarFixedBound_list :: Word -> Word -> [Word8] +wordVarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound) + +word64VarFixedBound_list :: Word64 -> Word64 -> [Word8] +word64VarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound) + +-- Somehow this function doesn't really make sense, as the bound must be +-- greater when interpreted as an unsigned integer. +-- +-- intVarFixedBound_list :: Int -> Int -> [Word8] +-- intVarFixedBound_list bound = wordVarFixedBound_list (fromIntegral bound) . fromIntegral + + +------------------------------------------------------------------------------ +-- Latin-1 aka Char8 +------------------------------------------------------------------------------ + +testsChar8 :: [Test] +testsChar8 = + [ testBoundedF "char8" char8_list BP.char8 ] + + +------------------------------------------------------------------------------ +-- ASCII +------------------------------------------------------------------------------ + +testsASCII :: [Test] +testsASCII = + [ testBoundedF "char7" char7_list BP.char7 + + , testBoundedB "int8Dec" dec_list BP.int8Dec + , testBoundedB "int16Dec" dec_list BP.int16Dec + , testBoundedB "int32Dec" dec_list BP.int32Dec + , testBoundedB "int64Dec" dec_list BP.int64Dec + , testBoundedB "intDec" dec_list BP.intDec + + , testBoundedB "word8Dec" dec_list BP.word8Dec + , testBoundedB "word16Dec" dec_list BP.word16Dec + , testBoundedB "word32Dec" dec_list BP.word32Dec + , testBoundedB "word64Dec" dec_list BP.word64Dec + , testBoundedB "wordDec" dec_list BP.wordDec + + , testBoundedB "word8Hex" hex_list BP.word8Hex + , testBoundedB "word16Hex" hex_list BP.word16Hex + , testBoundedB "word32Hex" hex_list BP.word32Hex + , testBoundedB "word64Hex" hex_list BP.word64Hex + , testBoundedB "wordHex" hex_list BP.wordHex + + , testBoundedF "word8HexFixed" wordHexFixed_list BP.word8HexFixed + , testBoundedF "word16HexFixed" wordHexFixed_list BP.word16HexFixed + , testBoundedF "word32HexFixed" wordHexFixed_list BP.word32HexFixed + , testBoundedF "word64HexFixed" wordHexFixed_list BP.word64HexFixed + + , testBoundedF "int8HexFixed" int8HexFixed_list BP.int8HexFixed + , testBoundedF "int16HexFixed" int16HexFixed_list BP.int16HexFixed + , testBoundedF "int32HexFixed" int32HexFixed_list BP.int32HexFixed + , testBoundedF "int64HexFixed" int64HexFixed_list BP.int64HexFixed + + , testF "floatHexFixed" floatHexFixed_list BP.floatHexFixed + , testF "doubleHexFixed" doubleHexFixed_list BP.doubleHexFixed + + , testFixedBoundF "wordDecFixedBound" + (genDecFixedBound_list 'x') (BP.wordDecFixedBound 'x') + + , testFixedBoundF "word64DecFixedBound" + (genDecFixedBound_list 'x') (BP.word64DecFixedBound 'x') + + , testFixedBoundF "wordHexFixedBound" + (genHexFixedBound_list 'x') (BP.wordHexFixedBound 'x') + + , testFixedBoundF "word64HexFixedBound" + (genHexFixedBound_list 'x') (BP.word64HexFixedBound 'x') + ] + +-- | PRE: positive bound and value. +genDecFixedBound_list :: (Show a, Integral a) + => Char -- ^ Padding character. + -> a -- ^ Max value to be encoded. + -> a -- ^ Value to encode. + -> [Word8] +genDecFixedBound_list padChar bound = + encodeASCII . pad . show + where + n = length $ show bound + pad cs = replicate (n - length cs) padChar ++ cs + +-- | PRE: positive bound and value. +genHexFixedBound_list :: (Show a, Integral a) + => Char -- ^ Padding character. + -> a -- ^ Max value to be encoded. + -> a -- ^ Value to encode. + -> [Word8] +genHexFixedBound_list padChar bound = + encodeASCII . pad . (`showHex` "") + where + n = length $ (`showHex` "") bound + pad cs = replicate (n - length cs) padChar ++ cs + + +------------------------------------------------------------------------------ +-- UTF-8 +------------------------------------------------------------------------------ + +testsUtf8 :: [Test] +testsUtf8 = + [ testBoundedB "charUtf8" charUtf8_list BP.charUtf8 ] + + +------------------------------------------------------------------------------ +-- BoundedPrim combinators +------------------------------------------------------------------------------ + +maybeB :: BP.BoundedPrim () -> BP.BoundedPrim a -> BP.BoundedPrim (Maybe a) +maybeB nothing just = maybe (Left ()) Right BP.>$< BP.eitherB nothing just + +testsCombinatorsB :: [Test] +testsCombinatorsB = + [ compareImpls "mapMaybe (via BoundedPrim)" + (L.pack . concatMap encChar) + (toLazyByteString . encViaBuilder) + + , compareImpls "filter (via BoundedPrim)" + (L.pack . filter (< 32)) + (toLazyByteString . BP.primMapListBounded (BP.condB (< 32) (BP.liftFixedToBounded BP.word8) BP.emptyB)) + + , compareImpls "pairB" + (L.pack . concatMap (\(c,w) -> charUtf8_list c ++ [w])) + (toLazyByteString . BP.primMapListBounded + ((\(c,w) -> (c,(w,undefined))) BP.>$< + BP.charUtf8 BP.>*< (BP.liftFixedToBounded BP.word8) BP.>*< (BP.liftFixedToBounded BP.emptyF))) + ] + where + encChar = maybe [112] (hostEndian_list . ord) + + encViaBuilder = BP.primMapListBounded $ maybeB (BP.liftFixedToBounded $ (\_ -> 112) BP.>$< BP.word8) + (ord BP.>$< (BP.liftFixedToBounded $ BP.intHost)) + + + + + + diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -0,0 +1,681 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Testing composition of 'Builders'. + +module Data.ByteString.Builder.Tests (tests) where + + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Writer + +import Foreign (Word, Word8, Word64, minusPtr) +import System.IO.Unsafe (unsafePerformIO) + +import Data.Char (ord, chr) +import qualified Data.DList as D +import Data.Foldable (asum, foldMap) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import Data.ByteString.Builder.ASCII +import Data.ByteString.Builder.Internal (Put, putBuilder, fromPut) +import qualified Data.ByteString.Builder.Internal as BI +import qualified Data.ByteString.Builder.Prim as BP +import qualified Data.ByteString.Builder.Prim.Extra as BP +import Data.ByteString.Builder.Prim.TestUtils + +import Numeric (readHex) + +import Control.Exception (evaluate) +import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode) +#if MIN_VERSION_base(4,2,0) +import System.IO (hSetEncoding, utf8) +#endif +import System.Directory +import Foreign (ForeignPtr, withForeignPtr, castPtr) + +import TestFramework +import Test.QuickCheck + ( Arbitrary(..), oneof, choose, listOf, elements ) +import Test.QuickCheck.Property + ( printTestCase, morallyDubiousIOProperty ) + + +tests :: [Test] +tests = + [ testBuilderRecipe +#if MIN_VERSION_base(4,2,0) + , testHandlePutBuilder +#endif + , testHandlePutBuilderChar8 + , testPut + , testRunBuilder + ] ++ + testsEncodingToBuilder ++ + testsBinary ++ + testsASCII ++ + testsChar8 ++ + testsUtf8 + + +------------------------------------------------------------------------------ +-- Testing 'Builder' execution +------------------------------------------------------------------------------ + +testBuilderRecipe :: Test +testBuilderRecipe = + testProperty "toLazyByteStringWith" $ testRecipe <$> arbitrary + where + testRecipe r = + printTestCase msg $ x1 == x2 + where + x1 = renderRecipe r + x2 = buildRecipe r + toString = map (chr . fromIntegral) + msg = unlines + [ "recipe: " ++ show r + , "render: " ++ toString x1 + , "build : " ++ toString x2 + , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + +#if MIN_VERSION_base(4,2,0) +testHandlePutBuilder :: Test +testHandlePutBuilder = + testProperty "hPutBuilder" testRecipe + where + testRecipe :: (String, String, String, Recipe) -> Bool + testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do + tempDir <- getTemporaryDirectory + (tempFile, tempH) <- openTempFile tempDir "TestBuilder" + -- switch to UTF-8 encoding + hSetEncoding tempH utf8 + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ mconcat + [stringUtf8 before, b, stringUtf8 between, b, stringUtf8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success +#endif + +testHandlePutBuilderChar8 :: Test +testHandlePutBuilderChar8 = + testProperty "char8 hPutBuilder" testRecipe + where + testRecipe :: (String, String, String, Recipe) -> Bool + testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do + tempDir <- getTemporaryDirectory + (tempFile, tempH) <- openTempFile tempDir "TestBuilder" + -- switch to binary / latin1 encoding + hSetBinaryMode tempH True + -- output recipe with intermediate direct writing to handle + let b = fst $ recipeComponents recipe + hPutStr tempH before + hPutBuilder tempH b + hPutStr tempH between + hPutBuilder tempH b + hPutStr tempH after + hClose tempH + -- read file + lbs <- L.readFile tempFile + _ <- evaluate (L.length $ lbs) + removeFile tempFile + -- compare to pure builder implementation + let lbsRef = toLazyByteString $ mconcat + [string8 before, b, string8 between, b, string8 after] + -- report + let msg = unlines + [ "task: " ++ show args + , "via file: " ++ show lbs + , "direct : " ++ show lbsRef + -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) + ] + success = lbs == lbsRef + unless success (error msg) + return success + + +-- Recipes with which to test the builder functions +--------------------------------------------------- + +data Mode = + Threshold Int + | Insert + | Copy + | Smart + | Hex + deriving( Eq, Ord, Show ) + +data Action = + SBS Mode S.ByteString + | LBS Mode L.ByteString + | W8 Word8 + | W8S [Word8] + | String String + | FDec Float + | DDec Double + | Flush + | EnsureFree Word + | ModState Int + deriving( Eq, Ord, Show ) + +data Strategy = Safe | Untrimmed + deriving( Eq, Ord, Show ) + +data Recipe = Recipe Strategy Int Int L.ByteString [Action] + deriving( Eq, Ord, Show ) + +renderRecipe :: Recipe -> [Word8] +renderRecipe (Recipe _ firstSize _ cont as) = + D.toList $ execWriter (evalStateT (mapM_ renderAction as) firstSize) + `mappend` renderLBS cont + where + renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs + renderAction (SBS _ bs) = tell $ D.fromList $ S.unpack bs + renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs + renderAction (LBS _ lbs) = tell $ renderLBS lbs + renderAction (W8 w) = tell $ return w + renderAction (W8S ws) = tell $ D.fromList ws + renderAction (String cs) = tell $ foldMap (D.fromList . charUtf8_list) cs + renderAction Flush = tell $ mempty + renderAction (EnsureFree _) = tell $ mempty + renderAction (FDec f) = tell $ D.fromList $ encodeASCII $ show f + renderAction (DDec d) = tell $ D.fromList $ encodeASCII $ show d + renderAction (ModState i) = do + s <- get + tell (D.fromList $ encodeASCII $ show s) + put (s - i) + + + renderLBS = D.fromList . L.unpack + hexWord8 = D.fromList . wordHexFixed_list + +buildAction :: Action -> StateT Int Put () +buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHex bs +buildAction (SBS Smart bs) = lift $ putBuilder $ byteString bs +buildAction (SBS Copy bs) = lift $ putBuilder $ byteStringCopy bs +buildAction (SBS Insert bs) = lift $ putBuilder $ byteStringInsert bs +buildAction (SBS (Threshold i) bs) = lift $ putBuilder $ byteStringThreshold i bs +buildAction (LBS Hex lbs) = lift $ putBuilder $ lazyByteStringHex lbs +buildAction (LBS Smart lbs) = lift $ putBuilder $ lazyByteString lbs +buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs +buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs +buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs +buildAction (W8 w) = lift $ putBuilder $ word8 w +buildAction (W8S ws) = lift $ putBuilder $ BP.primMapListFixed BP.word8 ws +buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs +buildAction (FDec f) = lift $ putBuilder $ floatDec f +buildAction (DDec d) = lift $ putBuilder $ doubleDec d +buildAction Flush = lift $ putBuilder $ flush +buildAction (EnsureFree minFree) = lift $ putBuilder $ ensureFree $ fromIntegral minFree +buildAction (ModState i) = do + s <- get + lift $ putBuilder $ intDec s + put (s - i) + +buildRecipe :: Recipe -> [Word8] +buildRecipe recipe = + L.unpack $ toLBS b + where + (b, toLBS) = recipeComponents recipe + + +recipeComponents :: Recipe -> (Builder, Builder -> L.ByteString) +recipeComponents (Recipe how firstSize otherSize cont as) = + (b, toLBS) + where + toLBS = toLazyByteStringWith (strategy how firstSize otherSize) cont + where + strategy Safe = safeStrategy + strategy Untrimmed = untrimmedStrategy + + b = fromPut $ evalStateT (mapM_ buildAction as) firstSize + + +-- 'Arbitary' instances +----------------------- + +instance Arbitrary L.ByteString where + arbitrary = L.fromChunks <$> listOf arbitrary + shrink lbs + | L.null lbs = [] + | otherwise = pure $ L.take (L.length lbs `div` 2) lbs + +instance Arbitrary S.ByteString where + arbitrary = + trim S.drop =<< trim S.take =<< S.pack <$> listOf arbitrary + where + trim f bs = oneof [pure bs, f <$> choose (0, S.length bs) <*> pure bs] + + shrink bs + | S.null bs = [] + | otherwise = pure $ S.take (S.length bs `div` 2) bs + +instance Arbitrary Mode where + arbitrary = oneof + [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex] + + shrink (Threshold i) = Threshold <$> shrink i + shrink _ = [] + +instance Arbitrary Action where + arbitrary = oneof + [ SBS <$> arbitrary <*> arbitrary + , LBS <$> arbitrary <*> arbitrary + , W8 <$> arbitrary + , W8S <$> listOf arbitrary + -- ensure that larger character codes are also tested + , String <$> listOf ((\c -> chr (ord c * ord c)) <$> arbitrary) + , pure Flush + -- never request more than 64kb free space + , (EnsureFree . (`mod` 0xffff)) <$> arbitrary + , FDec <$> arbitrary + , DDec <$> arbitrary + , ModState <$> arbitrary + ] + where + + shrink (SBS m bs) = + (SBS <$> shrink m <*> pure bs) <|> + (SBS <$> pure m <*> shrink bs) + shrink (LBS m lbs) = + (LBS <$> shrink m <*> pure lbs) <|> + (LBS <$> pure m <*> shrink lbs) + shrink (W8 w) = W8 <$> shrink w + shrink (W8S ws) = W8S <$> shrink ws + shrink (String cs) = String <$> shrink cs + shrink Flush = [] + shrink (EnsureFree i) = EnsureFree <$> shrink i + shrink (FDec f) = FDec <$> shrink f + shrink (DDec d) = DDec <$> shrink d + shrink (ModState i) = ModState <$> shrink i + +instance Arbitrary Strategy where + arbitrary = elements [Safe, Untrimmed] + shrink _ = [] + +instance Arbitrary Recipe where + arbitrary = + Recipe <$> arbitrary + <*> ((`mod` 33333) <$> arbitrary) -- bound max chunk-sizes + <*> ((`mod` 33337) <$> arbitrary) + <*> arbitrary + <*> listOf arbitrary + + -- shrinking the actions first is desirable + shrink (Recipe a b c d e) = asum + [ (\x -> Recipe a b c d x) <$> shrink e + , (\x -> Recipe a b c x e) <$> shrink d + , (\x -> Recipe a b x d e) <$> shrink c + , (\x -> Recipe a x c d e) <$> shrink b + , (\x -> Recipe x b c d e) <$> shrink a + ] + + +------------------------------------------------------------------------------ +-- Creating Builders from basic encodings +------------------------------------------------------------------------------ + +testsEncodingToBuilder :: [Test] +testsEncodingToBuilder = + [ test_encodeUnfoldrF + , test_encodeUnfoldrB + + , compareImpls "encodeSize/Chunked/Size/Chunked (recipe)" + (testBuilder id) + ( + parseChunks parseHexLen . + parseSizePrefix parseHexLen . + parseChunks parseVar . + parseSizePrefix parseHexLen . + testBuilder ( + prefixHexSize . + encodeVar . + prefixHexSize . + encodeHex + ) + ) + + ] + + +-- Unfoldr fused with encoding +------------------------------ + +test_encodeUnfoldrF :: Test +test_encodeUnfoldrF = + compareImpls "encodeUnfoldrF word8" id encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrFixed BP.word8 go + where + go [] = Nothing + go (w:ws) = Just (w, ws) + + +test_encodeUnfoldrB :: Test +test_encodeUnfoldrB = + compareImpls "encodeUnfoldrB charUtf8" (concatMap charUtf8_list) encode + where + toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty + encode = + L.unpack . toLBS . BP.primUnfoldrBounded BP.charUtf8 go + where + go [] = Nothing + go (c:cs) = Just (c, cs) + + +-- Chunked encoding and size prefix +----------------------------------- + +testBuilder :: (Builder -> Builder) -> Recipe -> L.ByteString +testBuilder f recipe = + toLBS (f b) + where + (b, toLBS) = recipeComponents $ clearTail recipe + -- need to remove tail of recipe to have a tighter + -- check on encodeWithSize + clearTail (Recipe how firstSize otherSize _ as) = + Recipe how firstSize otherSize L.empty as + +-- | Chunked encoding using base-128, variable-length encoding for the +-- chunk-size. +encodeVar :: Builder -> Builder +encodeVar = + (`mappend` BP.primFixed BP.word8 0) + . (BP.encodeChunked 5 BP.word64VarFixedBound BP.emptyB) + +-- | Chunked encoding using 0-padded, space-terminated hexadecimal numbers +-- for encoding the chunk-size. +encodeHex :: Builder -> Builder +encodeHex = + (`mappend` BP.primFixed (hexLen 0) 0) + . (BP.encodeChunked 7 hexLen BP.emptyB) + +hexLen :: Word64 -> BP.FixedPrim Word64 +hexLen bound = + (\x -> (x, ' ')) BP.>$< (BP.word64HexFixedBound '0' bound BP.>*< BP.char8) + +parseHexLen :: [Word8] -> (Int, [Word8]) +parseHexLen ws = case span (/= 32) ws of + (lenWS, 32:ws') -> case readHex (map (chr . fromIntegral) lenWS) of + [(len, [])] -> (len, ws') + _ -> error $ "hex parse failed: " ++ show ws + (_, _) -> error $ "unterminated hex-length:" ++ show ws + +parseChunks :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString +parseChunks parseLen = + L.pack . go . L.unpack + where + go ws + | chunkLen == 0 = rest + | chunkLen <= length ws' = chunk ++ go rest + | otherwise = error $ "too few bytes: " ++ show ws + where + (chunkLen, ws') = parseLen ws + (chunk, rest) = splitAt chunkLen ws' + + +-- | Prefix with size. We use an inner buffer size of 77 (almost primes are good) to +-- get several buffer full signals. +prefixHexSize :: Builder -> Builder +prefixHexSize = BP.encodeWithSize 77 hexLen + +parseSizePrefix :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString +parseSizePrefix parseLen = + L.pack . go . L.unpack + where + go ws + | len <= length ws' = take len ws' + | otherwise = error $ "too few bytes: " ++ show (len, ws, ws') + where + (len, ws') = parseLen ws + + +------------------------------------------------------------------------------ +-- Testing the Put monad +------------------------------------------------------------------------------ + +testPut :: Test +testPut = testGroup "Put monad" + [ testLaw "identity" (\v -> (pure id <*> putInt v) `eqPut` (putInt v)) + + , testLaw "composition" $ \(u, v, w) -> + (pure (.) <*> minusInt u <*> minusInt v <*> putInt w) `eqPut` + (minusInt u <*> (minusInt v <*> putInt w)) + + , testLaw "homomorphism" $ \(f, x) -> + (pure (f -) <*> pure x) `eqPut` (pure (f - x)) + + , testLaw "interchange" $ \(u, y) -> + (minusInt u <*> pure y) `eqPut` (pure ($ y) <*> minusInt u) + + , testLaw "ignore left value" $ \(u, v) -> + (putInt u *> putInt v) `eqPut` (pure (const id) <*> putInt u <*> putInt v) + + , testLaw "ignore right value" $ \(u, v) -> + (putInt u <* putInt v) `eqPut` (pure const <*> putInt u <*> putInt v) + + , testLaw "functor" $ \(f, x) -> + (fmap (f -) (putInt x)) `eqPut` (pure (f -) <*> putInt x) + + ] + where + putInt i = putBuilder (integerDec i) >> return i + minusInt i = (-) <$> putInt i + run p = toLazyByteString $ fromPut (do i <- p; _ <- putInt i; return ()) + eqPut p1 p2 = (run p1, run p2) + + testLaw name f = compareImpls name (fst . f) (snd . f) + + +------------------------------------------------------------------------------ +-- Testing the Driver <-> Builder protocol +------------------------------------------------------------------------------ + +-- | Ensure that there are at least 'n' free bytes for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + BI.builder step + where + step k br@(BI.BufferRange op ope) + | ope `minusPtr` op < minFree = return $ BI.bufferFull minFree op next + | otherwise = k br + where + next br'@(BI.BufferRange op' ope') + | freeSpace < minFree = + error $ "ensureFree: requested " ++ show minFree ++ " bytes, " ++ + "but got only " ++ show freeSpace ++ " bytes" + | otherwise = k br' + where + freeSpace = ope' `minusPtr` op' + + +------------------------------------------------------------------------------ +-- Testing the Builder runner +------------------------------------------------------------------------------ + +testRunBuilder :: Test +testRunBuilder = + testProperty "runBuilder" prop + where + prop actions = + morallyDubiousIOProperty $ do + let (builder, _) = recipeComponents recipe + expected = renderRecipe recipe + actual <- bufferWriterOutput (runBuilder builder) + return (S.unpack actual == expected) + where + recipe = Recipe Safe 0 0 mempty actions + +bufferWriterOutput :: BufferWriter -> IO S.ByteString +bufferWriterOutput bwrite0 = do + let len0 = 8 + buf <- S.mallocByteString len0 + bss <- go [] buf len0 bwrite0 + return (S.concat (reverse bss)) + where + go :: [S.ByteString] -> ForeignPtr Word8 -> Int -> BufferWriter -> IO [S.ByteString] + go bss !buf !len bwrite = do + (wc, next) <- withForeignPtr buf $ \ptr -> bwrite ptr len + bs <- getBuffer buf wc + case next of + Done -> return (bs:bss) + More m bwrite' | m <= len -> go (bs:bss) buf len bwrite' + | otherwise -> do let len' = m + buf' <- S.mallocByteString len' + go (bs:bss) buf' len' bwrite' + Chunk c bwrite' -> go (c:bs:bss) buf len bwrite' + + getBuffer :: ForeignPtr Word8 -> Int -> IO S.ByteString + getBuffer buf len = withForeignPtr buf $ \ptr -> + S.packCStringLen (castPtr ptr, len) + + +------------------------------------------------------------------------------ +-- Testing the pre-defined builders +------------------------------------------------------------------------------ + +testBuilderConstr :: (Arbitrary a, Show a) + => TestName -> (a -> [Word8]) -> (a -> Builder) -> Test +testBuilderConstr name ref mkBuilder = + testProperty name check + where + check x = + (ws ++ ws) == + (L.unpack $ toLazyByteString $ mkBuilder x `mappend` mkBuilder x) + where + ws = ref x + + +testsBinary :: [Test] +testsBinary = + [ testBuilderConstr "word8" bigEndian_list word8 + , testBuilderConstr "int8" bigEndian_list int8 + + -- big-endian + , testBuilderConstr "int16BE" bigEndian_list int16BE + , testBuilderConstr "int32BE" bigEndian_list int32BE + , testBuilderConstr "int64BE" bigEndian_list int64BE + + , testBuilderConstr "word16BE" bigEndian_list word16BE + , testBuilderConstr "word32BE" bigEndian_list word32BE + , testBuilderConstr "word64BE" bigEndian_list word64BE + + , testBuilderConstr "floatLE" (float_list littleEndian_list) floatLE + , testBuilderConstr "doubleLE" (double_list littleEndian_list) doubleLE + + -- little-endian + , testBuilderConstr "int16LE" littleEndian_list int16LE + , testBuilderConstr "int32LE" littleEndian_list int32LE + , testBuilderConstr "int64LE" littleEndian_list int64LE + + , testBuilderConstr "word16LE" littleEndian_list word16LE + , testBuilderConstr "word32LE" littleEndian_list word32LE + , testBuilderConstr "word64LE" littleEndian_list word64LE + + , testBuilderConstr "floatBE" (float_list bigEndian_list) floatBE + , testBuilderConstr "doubleBE" (double_list bigEndian_list) doubleBE + + -- host dependent + , testBuilderConstr "int16Host" hostEndian_list int16Host + , testBuilderConstr "int32Host" hostEndian_list int32Host + , testBuilderConstr "int64Host" hostEndian_list int64Host + , testBuilderConstr "intHost" hostEndian_list intHost + + , testBuilderConstr "word16Host" hostEndian_list word16Host + , testBuilderConstr "word32Host" hostEndian_list word32Host + , testBuilderConstr "word64Host" hostEndian_list word64Host + , testBuilderConstr "wordHost" hostEndian_list wordHost + + , testBuilderConstr "floatHost" (float_list hostEndian_list) floatHost + , testBuilderConstr "doubleHost" (double_list hostEndian_list) doubleHost + ] + +testsASCII :: [Test] +testsASCII = + [ testBuilderConstr "char7" char7_list char7 + , testBuilderConstr "string7" (concatMap char7_list) string7 + + , testBuilderConstr "int8Dec" dec_list int8Dec + , testBuilderConstr "int16Dec" dec_list int16Dec + , testBuilderConstr "int32Dec" dec_list int32Dec + , testBuilderConstr "int64Dec" dec_list int64Dec + , testBuilderConstr "intDec" dec_list intDec + + , testBuilderConstr "word8Dec" dec_list word8Dec + , testBuilderConstr "word16Dec" dec_list word16Dec + , testBuilderConstr "word32Dec" dec_list word32Dec + , testBuilderConstr "word64Dec" dec_list word64Dec + , testBuilderConstr "wordDec" dec_list wordDec + + , testBuilderConstr "integerDec" dec_list integerDec + , testBuilderConstr "floatDec" dec_list floatDec + , testBuilderConstr "doubleDec" dec_list doubleDec + + , testBuilderConstr "word8Hex" hex_list word8Hex + , testBuilderConstr "word16Hex" hex_list word16Hex + , testBuilderConstr "word32Hex" hex_list word32Hex + , testBuilderConstr "word64Hex" hex_list word64Hex + , testBuilderConstr "wordHex" hex_list wordHex + + , testBuilderConstr "word8HexFixed" wordHexFixed_list word8HexFixed + , testBuilderConstr "word16HexFixed" wordHexFixed_list word16HexFixed + , testBuilderConstr "word32HexFixed" wordHexFixed_list word32HexFixed + , testBuilderConstr "word64HexFixed" wordHexFixed_list word64HexFixed + + , testBuilderConstr "int8HexFixed" int8HexFixed_list int8HexFixed + , testBuilderConstr "int16HexFixed" int16HexFixed_list int16HexFixed + , testBuilderConstr "int32HexFixed" int32HexFixed_list int32HexFixed + , testBuilderConstr "int64HexFixed" int64HexFixed_list int64HexFixed + + , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed + , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed + ] + +testsChar8 :: [Test] +testsChar8 = + [ testBuilderConstr "charChar8" char8_list char8 + , testBuilderConstr "stringChar8" (concatMap char8_list) string8 + ] + +testsUtf8 :: [Test] +testsUtf8 = + [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 + , testBuilderConstr "stringUtf8" (concatMap charUtf8_list) stringUtf8 + ] diff --git a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs deleted file mode 100644 --- a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs +++ /dev/null @@ -1,344 +0,0 @@ --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- Testing utilities for comparing --- for an example on how to use the functions provided here. --- -module Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils ( - - -- * Testing 'FixedEncoding's - testF - , testBoundedF - - , testFixedBoundF - - , compareImpls - - -- * Testing 'BoundedEncoding's - , testBoundedB - - -- * Encoding reference implementations - - , charUtf8_list - , char8_list - - -- ** ASCII-based encodings - , encodeASCII - , encodeForcedASCII - , char7_list - , dec_list - , hex_list - , wordHexFixed_list - , int8HexFixed_list - , int16HexFixed_list - , int32HexFixed_list - , int64HexFixed_list - , floatHexFixed_list - , doubleHexFixed_list - - -- ** Binary - , parseVar - - , bigEndian_list - , littleEndian_list - , hostEndian_list - , float_list - , double_list - , coerceFloatToWord32 - , coerceDoubleToWord64 - - ) where - -import Control.Arrow (first) - -import Data.ByteString.Lazy.Builder.BasicEncoding -import Data.Char (chr, ord) - -import Numeric (showHex) - -#if MIN_VERSION_base(4,4,0) -import Foreign hiding (unsafePerformIO) -import System.IO.Unsafe (unsafePerformIO) -#else -import Foreign -#endif - -import System.ByteOrder -import Unsafe.Coerce (unsafeCoerce) - -import TestFramework -import Test.QuickCheck (Arbitrary(..)) - --- Helper functions -------------------- - --- | Quickcheck test that includes a check that the property holds on the --- bounds of a bounded value. -testBoundedProperty :: forall a. (Arbitrary a, Show a, Bounded a) - => String -> (a -> Bool) -> Test -testBoundedProperty name p = testGroup name - [ testProperty "arbitrary" p - , testCase "bounds" $ p (minBound :: a) - && p (maxBound :: a) - ] - --- | Quote a 'String' nicely. -quote :: String -> String -quote cs = '`' : cs ++ "'" - --- | Quote a @[Word8]@ list as as 'String'. -quoteWord8s :: [Word8] -> String -quoteWord8s = quote . map (chr . fromIntegral) - - --- FixedEncoding ----------------- - --- TODO: Port code that checks for low-level properties of basic encodings (no --- overwrites, all bytes written, etc.) from old 'system-io-write' library - --- | Test a 'FixedEncoding' against a reference implementation. -testF :: (Arbitrary a, Show a) - => String - -> (a -> [Word8]) - -> FixedEncoding a - -> Test -testF name ref fe = - testProperty name prop - where - prop x - | y == y' = True - | otherwise = error $ unlines $ - [ "testF: results disagree for " ++ quote (show x) - , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y - , " reference: " ++ show y'++ " " ++ quoteWord8s y' - ] - where - y = evalF fe x - y' = ref x - --- | Test a 'FixedEncoding' of a bounded value against a reference implementation --- and ensure that the bounds are always included as testcases. -testBoundedF :: (Arbitrary a, Bounded a, Show a) - => String - -> (a -> [Word8]) - -> FixedEncoding a - -> Test -testBoundedF name ref fe = - testBoundedProperty name $ \x -> evalF fe x == ref x - --- FixedEncoding derived from a bound on a given value. - -testFixedBoundF :: (Arbitrary a, Show a, Integral a) - => String - -> (a -> a -> [Word8]) - -> (a -> FixedEncoding a) - -> Test -testFixedBoundF name ref bfe = - testProperty name prop - where - prop (b, x0) - | y == y' = True - | otherwise = error $ unlines $ - [ "testF: results disagree for " ++ quote (show (b, x)) - , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y - , " reference: " ++ show y'++ " " ++ quoteWord8s y' - ] - where - x | b == 0 = 0 - | otherwise = x0 `mod` b - y = evalF (bfe b) x - y' = ref b x - - --- BoundedEncoding ------------------- - --- | Test a 'BoundedEncoding' of a bounded value against a reference implementation --- and ensure that the bounds are always included as testcases. -testBoundedB :: (Arbitrary a, Bounded a, Show a) - => String - -> (a -> [Word8]) - -> BoundedEncoding a - -> Test -testBoundedB name ref fe = - testBoundedProperty name check - where - check x - | y == y' = True - | otherwise = error $ unlines $ - [ "testBoundedB: results disagree for " ++ quote (show x) - , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y - , " reference: " ++ show y'++ " " ++ quoteWord8s y' - ] - where - y = evalB fe x - y' = ref x - --- | Compare two implementations of a function. -compareImpls :: (Arbitrary a, Show a, Show b, Eq b) - => TestName -> (a -> b) -> (a -> b) -> Test -compareImpls name f1 f2 = - testProperty name check - where - check x - | y1 == y2 = True - | otherwise = error $ unlines $ - [ "compareImpls: results disagree for " ++ quote (show x) - , " f1: " ++ show y1 - , " f2: " ++ show y2 - ] - where - y1 = f1 x - y2 = f2 x - - - ------------------------------------------------------------------------------- --- Encoding reference implementations ------------------------------------------------------------------------------- - --- | Char8 encoding: truncate Unicode codepoint to 8-bits. -char8_list :: Char -> [Word8] -char8_list = return . fromIntegral . ord - --- | Encode a Haskell String to a list of Word8 values, in UTF8 format. --- --- Copied from 'utf8-string-0.3.6' to make tests self-contained. --- Copyright (c) 2007, Galois Inc. All rights reserved. --- -charUtf8_list :: Char -> [Word8] -charUtf8_list = - map fromIntegral . encode . ord - where - encode oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- ASCII-based encodings ------------------------- - --- | Encode a 'String' of only ASCII characters using the ASCII encoding. -encodeASCII :: String -> [Word8] -encodeASCII = - map encode - where - encode c - | c < '\x7f' = fromIntegral $ ord c - | otherwise = error $ "encodeASCII: non-ASCII character '" ++ [c] ++ "'" - --- | Encode an arbitrary 'String' by truncating its characters to the least --- significant 7-bits. -encodeForcedASCII :: String -> [Word8] -encodeForcedASCII = map ((.&. 0x7f) . fromIntegral . ord) - -char7_list :: Char -> [Word8] -char7_list = encodeForcedASCII . return - -dec_list :: Show a => a -> [Word8] -dec_list = encodeASCII . show - -hex_list :: (Integral a, Show a) => a -> [Word8] -hex_list = encodeASCII . (\x -> showHex x "") - -wordHexFixed_list :: (Storable a, Integral a, Show a) => a -> [Word8] -wordHexFixed_list x = - encodeASCII $ pad (2 * sizeOf x) $ showHex x "" - where - pad n cs = replicate (n - length cs) '0' ++ cs - -int8HexFixed_list :: Int8 -> [Word8] -int8HexFixed_list = wordHexFixed_list . (fromIntegral :: Int8 -> Word8 ) - -int16HexFixed_list :: Int16 -> [Word8] -int16HexFixed_list = wordHexFixed_list . (fromIntegral :: Int16 -> Word16) - -int32HexFixed_list :: Int32 -> [Word8] -int32HexFixed_list = wordHexFixed_list . (fromIntegral :: Int32 -> Word32) - -int64HexFixed_list :: Int64 -> [Word8] -int64HexFixed_list = wordHexFixed_list . (fromIntegral :: Int64 -> Word64) - -floatHexFixed_list :: Float -> [Word8] -floatHexFixed_list = float_list wordHexFixed_list - -doubleHexFixed_list :: Double -> [Word8] -doubleHexFixed_list = double_list wordHexFixed_list - --- Binary ---------- - -bigEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] -bigEndian_list = reverse . littleEndian_list - -littleEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] -littleEndian_list x = - map (fromIntegral . (x `shiftR`) . (8*)) $ [0..sizeOf x - 1] - -hostEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8] -hostEndian_list = case byteOrder of - LittleEndian -> littleEndian_list - BigEndian -> bigEndian_list - _ -> error $ - "bounded-encoding: unsupported byteorder '" ++ show byteOrder ++ "'" - - -float_list :: (Word32 -> [Word8]) -> Float -> [Word8] -float_list f = f . coerceFloatToWord32 - -double_list :: (Word64 -> [Word8]) -> Double -> [Word8] -double_list f = f . coerceDoubleToWord64 - --- Note that the following use of unsafeCoerce is not guaranteed to be --- safe on GHC 7.0 and less. The reason is probably the following ticket: --- --- http://hackage.haskell.org/trac/ghc/ticket/4092 --- --- However, that only applies if the value is loaded in a register. We --- avoid this by coercing only boxed values and ensuring that they --- remain boxed using a NOINLINE pragma. --- - --- | Super unsafe coerce a 'Float' to a 'Word32'. We have to explicitly mask --- out the higher bits in case we are working on a 64-bit machine. -{-# NOINLINE coerceFloatToWord32 #-} -coerceFloatToWord32 :: Float -> Word32 -coerceFloatToWord32 = (.&. maxBound) . unsafeCoerce - --- | Super unsafe coerce a 'Double' to a 'Word64'. Currently, there are no --- > 64 bit machines supported by GHC. But we just play it safe. -{-# NOINLINE coerceDoubleToWord64 #-} -coerceDoubleToWord64 :: Double -> Word64 -coerceDoubleToWord64 = (.&. maxBound) . unsafeCoerce - --- | Parse a variable length encoding -parseVar :: (Num a, Bits a) => [Word8] -> (a, [Word8]) -parseVar = - go - where - go [] = error "parseVar: unterminated variable length int" - go (w:ws) - | w .&. 0x80 == 0 = (fromIntegral w, ws) - | otherwise = first add (go ws) - where - add x = (x `shiftL` 7) .|. (fromIntegral w .&. 0x7f) - - diff --git a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs deleted file mode 100644 --- a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- Testing all encodings provided by this library. - -module Data.ByteString.Lazy.Builder.BasicEncoding.Tests (tests) where - -import Control.Arrow (first) - -import Data.Char (ord) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Builder -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as BE -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Extras as BE -import Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils - -import Numeric (showHex) - -import Foreign - -import TestFramework -import Test.QuickCheck (Arbitrary) - - -tests :: [Test] -tests = concat [ testsBinary, testsASCII, testsChar8, testsUtf8 - , testsCombinatorsB ] - - ------------------------------------------------------------------------------- --- Binary ------------------------------------------------------------------------------- - -testsBinary :: [Test] -testsBinary = - [ testBoundedF "word8" bigEndian_list BE.word8 - , testBoundedF "int8" bigEndian_list BE.int8 - - -- big-endian - , testBoundedF "int16BE" bigEndian_list BE.int16BE - , testBoundedF "int32BE" bigEndian_list BE.int32BE - , testBoundedF "int64BE" bigEndian_list BE.int64BE - - , testBoundedF "word16BE" bigEndian_list BE.word16BE - , testBoundedF "word32BE" bigEndian_list BE.word32BE - , testBoundedF "word64BE" bigEndian_list BE.word64BE - - , testF "floatLE" (float_list littleEndian_list) BE.floatLE - , testF "doubleLE" (double_list littleEndian_list) BE.doubleLE - - -- little-endian - , testBoundedF "int16LE" littleEndian_list BE.int16LE - , testBoundedF "int32LE" littleEndian_list BE.int32LE - , testBoundedF "int64LE" littleEndian_list BE.int64LE - - , testBoundedF "word16LE" littleEndian_list BE.word16LE - , testBoundedF "word32LE" littleEndian_list BE.word32LE - , testBoundedF "word64LE" littleEndian_list BE.word64LE - - , testF "floatBE" (float_list bigEndian_list) BE.floatBE - , testF "doubleBE" (double_list bigEndian_list) BE.doubleBE - - -- host dependent - , testBoundedF "int16Host" hostEndian_list BE.int16Host - , testBoundedF "int32Host" hostEndian_list BE.int32Host - , testBoundedF "int64Host" hostEndian_list BE.int64Host - , testBoundedF "intHost" hostEndian_list BE.intHost - - , testBoundedF "word16Host" hostEndian_list BE.word16Host - , testBoundedF "word32Host" hostEndian_list BE.word32Host - , testBoundedF "word64Host" hostEndian_list BE.word64Host - , testBoundedF "wordHost" hostEndian_list BE.wordHost - - , testF "floatHost" (float_list hostEndian_list) BE.floatHost - , testF "doubleHost" (double_list hostEndian_list) BE.doubleHost - - , testBoundedB "word8Var" genVar_list BE.word8Var - , testBoundedB "word16Var" genVar_list BE.word16Var - , testBoundedB "word32Var" genVar_list BE.word32Var - , testBoundedB "word64Var" genVar_list BE.word64Var - , testBoundedB "wordVar" genVar_list BE.wordVar - - , testBoundedB "int8Var" int8Var_list BE.int8Var - , testBoundedB "int16Var" int16Var_list BE.int16Var - , testBoundedB "int32Var" int32Var_list BE.int32Var - , testBoundedB "int64Var" int64Var_list BE.int64Var - , testBoundedB "intVar" intVar_list BE.intVar - - , testBoundedB "int8VarSigned" (int8Var_list . zigZag) BE.int8VarSigned - , testBoundedB "int16VarSigned" (int16Var_list . zigZag) BE.int16VarSigned - , testBoundedB "int32VarSigned" (int32Var_list . zigZag) BE.int32VarSigned - , testBoundedB "int64VarSigned" (int64Var_list . zigZag) BE.int64VarSigned - , testBoundedB "intVarSigned" (intVar_list . zigZag) BE.intVarSigned - - , testGroup "parseable" - [ prop_zigZag_parseable "int8VarSigned" unZigZagInt8 BE.int8VarSigned - , prop_zigZag_parseable "int16VarSigned" unZigZagInt16 BE.int16VarSigned - , prop_zigZag_parseable "int32VarSigned" unZigZagInt32 BE.int32VarSigned - , prop_zigZag_parseable "int64VarSigned" unZigZagInt64 BE.int64VarSigned - , prop_zigZag_parseable "intVarSigned" unZigZagInt BE.intVarSigned - ] - - , testFixedBoundF "wordVarFixedBound" wordVarFixedBound_list BE.wordVarFixedBound - , testFixedBoundF "word64VarFixedBound" word64VarFixedBound_list BE.word64VarFixedBound - - ] - - --- Variable length encodings ----------------------------- - --- | Variable length encoding. -genVar_list :: (Ord a, Num a, Bits a, Integral a) => a -> [Word8] -genVar_list x - | x <= 0x7f = sevenBits : [] - | otherwise = (sevenBits .|. 0x80) : genVar_list (x `shiftR` 7) - where - sevenBits = fromIntegral x .&. 0x7f - -int8Var_list :: Int8 -> [Word8] -int8Var_list = genVar_list . (fromIntegral :: Int8 -> Word8) - -int16Var_list :: Int16 -> [Word8] -int16Var_list = genVar_list . (fromIntegral :: Int16 -> Word16) - -int32Var_list :: Int32 -> [Word8] -int32Var_list = genVar_list . (fromIntegral :: Int32 -> Word32) - -int64Var_list :: Int64 -> [Word8] -int64Var_list = genVar_list . (fromIntegral :: Int64 -> Word64) - -intVar_list :: Int -> [Word8] -intVar_list = genVar_list . (fromIntegral :: Int -> Word) - - --- | The so-called \"zig-zag\" encoding from Google's protocol buffers. --- It maps integers of small magnitude to naturals of small --- magnitude by encoding negative integers as odd naturals and positive --- integers as even naturals. --- --- For example: @0 -> 0, -1 -> 1, 1 -> 2, -2 -> 3, 2 -> 4, ...@ --- --- PRE: 'a' must be a signed integer type. -zigZag :: (Storable a, Bits a) => a -> a -zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1)) - - --- | Reversing the zigZag encoding. --- --- PRE: 'a' must be an unsigned integer type. --- --- forall x. fromIntegral x == --- unZigZag ((fromIntegral :: IntX -> WordX) (zigZag x)) --- -unZigZag :: (Storable a, Num a, Bits a) => a -> a -unZigZag x = (x `shiftR` 1) `xor` negate (x .&. 1) - -unZigZagInt8 :: Int8 -> Int8 -unZigZagInt8 = (fromIntegral :: Word8 -> Int8) . unZigZag . fromIntegral - -unZigZagInt16 :: Int16 -> Int16 -unZigZagInt16 = (fromIntegral :: Word16 -> Int16) . unZigZag . fromIntegral - -unZigZagInt32 :: Int32 -> Int32 -unZigZagInt32 = (fromIntegral :: Word32 -> Int32) . unZigZag . fromIntegral - -unZigZagInt64 :: Int64 -> Int64 -unZigZagInt64 = (fromIntegral :: Word64 -> Int64) . unZigZag . fromIntegral - -unZigZagInt :: Int -> Int -unZigZagInt = (fromIntegral :: Word -> Int) . unZigZag . fromIntegral - --- | Check that the 'intVarSigned' encodings are parseable. -prop_zigZag_parseable :: (Arbitrary t, Num b, Bits b, Show t, Eq t) - => String -> (b -> t) -> BE.BoundedEncoding t -> Test -prop_zigZag_parseable name unZig be = - compareImpls name (\x -> (x, [])) (first unZig . parseVar . BE.evalB be) - --- | Variable length encoding to a fixed number of bytes (pad / truncate). -genVarFixedBound_list :: (Ord a, Num a, Bits a, Integral a) - => Int - -> a -> [Word8] -genVarFixedBound_list n x - | n <= 1 = sevenBits : [] - | otherwise = (sevenBits .|. 0x80) : genVarFixedBound_list (n - 1) (x `shiftR` 7) - where - sevenBits = fromIntegral x .&. 0x7f - -wordVarFixedBound_list :: Word -> Word -> [Word8] -wordVarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound) - -word64VarFixedBound_list :: Word64 -> Word64 -> [Word8] -word64VarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound) - --- Somehow this function doesn't really make sense, as the bound must be --- greater when interpreted as an unsigned integer. --- --- intVarFixedBound_list :: Int -> Int -> [Word8] --- intVarFixedBound_list bound = wordVarFixedBound_list (fromIntegral bound) . fromIntegral - - ------------------------------------------------------------------------------- --- Latin-1 aka Char8 ------------------------------------------------------------------------------- - -testsChar8 :: [Test] -testsChar8 = - [ testBoundedF "char8" char8_list BE.char8 ] - - ------------------------------------------------------------------------------- --- ASCII ------------------------------------------------------------------------------- - -testsASCII :: [Test] -testsASCII = - [ testBoundedF "char7" char7_list BE.char7 - - , testBoundedB "int8Dec" dec_list BE.int8Dec - , testBoundedB "int16Dec" dec_list BE.int16Dec - , testBoundedB "int32Dec" dec_list BE.int32Dec - , testBoundedB "int64Dec" dec_list BE.int64Dec - , testBoundedB "intDec" dec_list BE.intDec - - , testBoundedB "word8Dec" dec_list BE.word8Dec - , testBoundedB "word16Dec" dec_list BE.word16Dec - , testBoundedB "word32Dec" dec_list BE.word32Dec - , testBoundedB "word64Dec" dec_list BE.word64Dec - , testBoundedB "wordDec" dec_list BE.wordDec - - , testBoundedB "word8Hex" hex_list BE.word8Hex - , testBoundedB "word16Hex" hex_list BE.word16Hex - , testBoundedB "word32Hex" hex_list BE.word32Hex - , testBoundedB "word64Hex" hex_list BE.word64Hex - , testBoundedB "wordHex" hex_list BE.wordHex - - , testBoundedF "word8HexFixed" wordHexFixed_list BE.word8HexFixed - , testBoundedF "word16HexFixed" wordHexFixed_list BE.word16HexFixed - , testBoundedF "word32HexFixed" wordHexFixed_list BE.word32HexFixed - , testBoundedF "word64HexFixed" wordHexFixed_list BE.word64HexFixed - - , testBoundedF "int8HexFixed" int8HexFixed_list BE.int8HexFixed - , testBoundedF "int16HexFixed" int16HexFixed_list BE.int16HexFixed - , testBoundedF "int32HexFixed" int32HexFixed_list BE.int32HexFixed - , testBoundedF "int64HexFixed" int64HexFixed_list BE.int64HexFixed - - , testF "floatHexFixed" floatHexFixed_list BE.floatHexFixed - , testF "doubleHexFixed" doubleHexFixed_list BE.doubleHexFixed - - , testFixedBoundF "wordDecFixedBound" - (genDecFixedBound_list 'x') (BE.wordDecFixedBound 'x') - - , testFixedBoundF "word64DecFixedBound" - (genDecFixedBound_list 'x') (BE.word64DecFixedBound 'x') - - , testFixedBoundF "wordHexFixedBound" - (genHexFixedBound_list 'x') (BE.wordHexFixedBound 'x') - - , testFixedBoundF "word64HexFixedBound" - (genHexFixedBound_list 'x') (BE.word64HexFixedBound 'x') - ] - --- | PRE: positive bound and value. -genDecFixedBound_list :: (Show a, Integral a) - => Char -- ^ Padding character. - -> a -- ^ Max value to be encoded. - -> a -- ^ Value to encode. - -> [Word8] -genDecFixedBound_list padChar bound = - encodeASCII . pad . show - where - n = length $ show bound - pad cs = replicate (n - length cs) padChar ++ cs - --- | PRE: positive bound and value. -genHexFixedBound_list :: (Show a, Integral a) - => Char -- ^ Padding character. - -> a -- ^ Max value to be encoded. - -> a -- ^ Value to encode. - -> [Word8] -genHexFixedBound_list padChar bound = - encodeASCII . pad . (`showHex` "") - where - n = length $ (`showHex` "") bound - pad cs = replicate (n - length cs) padChar ++ cs - - ------------------------------------------------------------------------------- --- UTF-8 ------------------------------------------------------------------------------- - -testsUtf8 :: [Test] -testsUtf8 = - [ testBoundedB "charUtf8" charUtf8_list BE.charUtf8 ] - - ------------------------------------------------------------------------------- --- BoundedEncoding combinators ------------------------------------------------------------------------------- - -maybeB :: BE.BoundedEncoding () -> BE.BoundedEncoding a -> BE.BoundedEncoding (Maybe a) -maybeB nothing just = maybe (Left ()) Right BE.>$< BE.eitherB nothing just - -testsCombinatorsB :: [Test] -testsCombinatorsB = - [ compareImpls "mapMaybe (via BoundedEncoding)" - (L.pack . concatMap encChar) - (toLazyByteString . encViaBuilder) - - , compareImpls "filter (via BoundedEncoding)" - (L.pack . filter (< 32)) - (toLazyByteString . BE.encodeListWithB (BE.ifB (< 32) (BE.fromF BE.word8) BE.emptyB)) - - , compareImpls "pairB" - (L.pack . concatMap (\(c,w) -> charUtf8_list c ++ [w])) - (toLazyByteString . BE.encodeListWithB - ((\(c,w) -> (c,(w,undefined))) BE.>$< - BE.charUtf8 BE.>*< (BE.fromF BE.word8) BE.>*< (BE.fromF BE.emptyF))) - ] - where - encChar = maybe [112] (hostEndian_list . ord) - - encViaBuilder = BE.encodeListWithB $ maybeB (BE.fromF $ (\_ -> 112) BE.>$< BE.word8) - (ord BE.>$< (BE.fromF $ BE.intHost)) - - - - - - diff --git a/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs b/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs deleted file mode 100644 --- a/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs +++ /dev/null @@ -1,636 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- Testing composition of 'Builders'. - -module Data.ByteString.Lazy.Builder.Tests (tests) where - - -import Control.Applicative -import Control.Monad.State -import Control.Monad.Writer - -import Foreign (Word, Word8, Word64, minusPtr) -import System.IO.Unsafe (unsafePerformIO) - -import Data.Char (ord, chr) -import qualified Data.DList as D -import Data.Foldable (asum, foldMap) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import Data.ByteString.Lazy.Builder -import Data.ByteString.Lazy.Builder.Extras -import Data.ByteString.Lazy.Builder.ASCII -import Data.ByteString.Lazy.Builder.Internal (Put, putBuilder, fromPut) -import qualified Data.ByteString.Lazy.Builder.Internal as BI -import qualified Data.ByteString.Lazy.Builder.BasicEncoding as BE -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Extras as BE -import Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils - -import Numeric (readHex) - -import Control.Exception (evaluate) -import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode) -#if MIN_VERSION_base(4,2,0) -import System.IO (hSetEncoding, utf8) -#endif -import System.Directory - -import TestFramework -import Test.QuickCheck - ( Arbitrary(..), oneof, choose, listOf, elements ) -import Test.QuickCheck.Property (printTestCase) - - -tests :: [Test] -tests = - [ testBuilderRecipe -#if MIN_VERSION_base(4,2,0) - , testHandlePutBuilder -#endif - , testHandlePutBuilderChar8 - , testPut - ] ++ - testsEncodingToBuilder ++ - testsBinary ++ - testsASCII ++ - testsChar8 ++ - testsUtf8 - - ------------------------------------------------------------------------------- --- Testing 'Builder' execution ------------------------------------------------------------------------------- - -testBuilderRecipe :: Test -testBuilderRecipe = - testProperty "toLazyByteStringWith" $ testRecipe <$> arbitrary - where - testRecipe r = - printTestCase msg $ x1 == x2 - where - x1 = renderRecipe r - x2 = buildRecipe r - toString = map (chr . fromIntegral) - msg = unlines - [ "recipe: " ++ show r - , "render: " ++ toString x1 - , "build : " ++ toString x2 - , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) - ] - -#if MIN_VERSION_base(4,2,0) -testHandlePutBuilder :: Test -testHandlePutBuilder = - testProperty "hPutBuilder" testRecipe - where - testRecipe :: (String, String, String, Recipe) -> Bool - testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do - tempDir <- getTemporaryDirectory - (tempFile, tempH) <- openTempFile tempDir "TestBuilder" - -- switch to UTF-8 encoding - hSetEncoding tempH utf8 - -- output recipe with intermediate direct writing to handle - let b = fst $ recipeComponents recipe - hPutStr tempH before - hPutBuilder tempH b - hPutStr tempH between - hPutBuilder tempH b - hPutStr tempH after - hClose tempH - -- read file - lbs <- L.readFile tempFile - _ <- evaluate (L.length $ lbs) - removeFile tempFile - -- compare to pure builder implementation - let lbsRef = toLazyByteString $ mconcat - [stringUtf8 before, b, stringUtf8 between, b, stringUtf8 after] - -- report - let msg = unlines - [ "task: " ++ show args - , "via file: " ++ show lbs - , "direct : " ++ show lbsRef - -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) - ] - success = lbs == lbsRef - unless success (error msg) - return success -#endif - -testHandlePutBuilderChar8 :: Test -testHandlePutBuilderChar8 = - testProperty "char8 hPutBuilder" testRecipe - where - testRecipe :: (String, String, String, Recipe) -> Bool - testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do - tempDir <- getTemporaryDirectory - (tempFile, tempH) <- openTempFile tempDir "TestBuilder" - -- switch to binary / latin1 encoding - hSetBinaryMode tempH True - -- output recipe with intermediate direct writing to handle - let b = fst $ recipeComponents recipe - hPutStr tempH before - hPutBuilder tempH b - hPutStr tempH between - hPutBuilder tempH b - hPutStr tempH after - hClose tempH - -- read file - lbs <- L.readFile tempFile - _ <- evaluate (L.length $ lbs) - removeFile tempFile - -- compare to pure builder implementation - let lbsRef = toLazyByteString $ mconcat - [string8 before, b, string8 between, b, string8 after] - -- report - let msg = unlines - [ "task: " ++ show args - , "via file: " ++ show lbs - , "direct : " ++ show lbsRef - -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2) - ] - success = lbs == lbsRef - unless success (error msg) - return success - - --- Recipes with which to test the builder functions ---------------------------------------------------- - -data Mode = - Threshold Int - | Insert - | Copy - | Smart - | Hex - deriving( Eq, Ord, Show ) - -data Action = - SBS Mode S.ByteString - | LBS Mode L.ByteString - | W8 Word8 - | W8S [Word8] - | String String - | FDec Float - | DDec Double - | Flush - | EnsureFree Word - | ModState Int - deriving( Eq, Ord, Show ) - -data Strategy = Safe | Untrimmed - deriving( Eq, Ord, Show ) - -data Recipe = Recipe Strategy Int Int L.ByteString [Action] - deriving( Eq, Ord, Show ) - -renderRecipe :: Recipe -> [Word8] -renderRecipe (Recipe _ firstSize _ cont as) = - D.toList $ execWriter (evalStateT (mapM_ renderAction as) firstSize) - `mappend` renderLBS cont - where - renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs - renderAction (SBS _ bs) = tell $ D.fromList $ S.unpack bs - renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs - renderAction (LBS _ lbs) = tell $ renderLBS lbs - renderAction (W8 w) = tell $ return w - renderAction (W8S ws) = tell $ D.fromList ws - renderAction (String cs) = tell $ foldMap (D.fromList . charUtf8_list) cs - renderAction Flush = tell $ mempty - renderAction (EnsureFree _) = tell $ mempty - renderAction (FDec f) = tell $ D.fromList $ encodeASCII $ show f - renderAction (DDec d) = tell $ D.fromList $ encodeASCII $ show d - renderAction (ModState i) = do - s <- get - tell (D.fromList $ encodeASCII $ show s) - put (s - i) - - - renderLBS = D.fromList . L.unpack - hexWord8 = D.fromList . wordHexFixed_list - -buildAction :: Action -> StateT Int Put () -buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHexFixed bs -buildAction (SBS Smart bs) = lift $ putBuilder $ byteString bs -buildAction (SBS Copy bs) = lift $ putBuilder $ byteStringCopy bs -buildAction (SBS Insert bs) = lift $ putBuilder $ byteStringInsert bs -buildAction (SBS (Threshold i) bs) = lift $ putBuilder $ byteStringThreshold i bs -buildAction (LBS Hex lbs) = lift $ putBuilder $ lazyByteStringHexFixed lbs -buildAction (LBS Smart lbs) = lift $ putBuilder $ lazyByteString lbs -buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs -buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs -buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs -buildAction (W8 w) = lift $ putBuilder $ word8 w -buildAction (W8S ws) = lift $ putBuilder $ BE.encodeListWithF BE.word8 ws -buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs -buildAction (FDec f) = lift $ putBuilder $ floatDec f -buildAction (DDec d) = lift $ putBuilder $ doubleDec d -buildAction Flush = lift $ putBuilder $ flush -buildAction (EnsureFree minFree) = lift $ putBuilder $ ensureFree $ fromIntegral minFree -buildAction (ModState i) = do - s <- get - lift $ putBuilder $ intDec s - put (s - i) - -buildRecipe :: Recipe -> [Word8] -buildRecipe recipe = - L.unpack $ toLBS b - where - (b, toLBS) = recipeComponents recipe - - -recipeComponents :: Recipe -> (Builder, Builder -> L.ByteString) -recipeComponents (Recipe how firstSize otherSize cont as) = - (b, toLBS) - where - toLBS = toLazyByteStringWith (strategy how firstSize otherSize) cont - where - strategy Safe = safeStrategy - strategy Untrimmed = untrimmedStrategy - - b = fromPut $ evalStateT (mapM_ buildAction as) firstSize - - --- 'Arbitary' instances ------------------------ - -instance Arbitrary L.ByteString where - arbitrary = L.fromChunks <$> listOf arbitrary - shrink lbs - | L.null lbs = [] - | otherwise = pure $ L.take (L.length lbs `div` 2) lbs - -instance Arbitrary S.ByteString where - arbitrary = - trim S.drop =<< trim S.take =<< S.pack <$> listOf arbitrary - where - trim f bs = oneof [pure bs, f <$> choose (0, S.length bs) <*> pure bs] - - shrink bs - | S.null bs = [] - | otherwise = pure $ S.take (S.length bs `div` 2) bs - -instance Arbitrary Mode where - arbitrary = oneof - [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex] - - shrink (Threshold i) = Threshold <$> shrink i - shrink _ = [] - -instance Arbitrary Action where - arbitrary = oneof - [ SBS <$> arbitrary <*> arbitrary - , LBS <$> arbitrary <*> arbitrary - , W8 <$> arbitrary - , W8S <$> listOf arbitrary - -- ensure that larger character codes are also tested - , String <$> listOf ((\c -> chr (ord c * ord c)) <$> arbitrary) - , pure Flush - -- never request more than 64kb free space - , (EnsureFree . (`mod` 0xffff)) <$> arbitrary - , FDec <$> arbitrary - , DDec <$> arbitrary - , ModState <$> arbitrary - ] - where - - shrink (SBS m bs) = - (SBS <$> shrink m <*> pure bs) <|> - (SBS <$> pure m <*> shrink bs) - shrink (LBS m lbs) = - (LBS <$> shrink m <*> pure lbs) <|> - (LBS <$> pure m <*> shrink lbs) - shrink (W8 w) = W8 <$> shrink w - shrink (W8S ws) = W8S <$> shrink ws - shrink (String cs) = String <$> shrink cs - shrink Flush = [] - shrink (EnsureFree i) = EnsureFree <$> shrink i - shrink (FDec f) = FDec <$> shrink f - shrink (DDec d) = DDec <$> shrink d - shrink (ModState i) = ModState <$> shrink i - -instance Arbitrary Strategy where - arbitrary = elements [Safe, Untrimmed] - shrink _ = [] - -instance Arbitrary Recipe where - arbitrary = - Recipe <$> arbitrary - <*> ((`mod` 33333) <$> arbitrary) -- bound max chunk-sizes - <*> ((`mod` 33337) <$> arbitrary) - <*> arbitrary - <*> listOf arbitrary - - -- shrinking the actions first is desirable - shrink (Recipe a b c d e) = asum - [ (\x -> Recipe a b c d x) <$> shrink e - , (\x -> Recipe a b c x e) <$> shrink d - , (\x -> Recipe a b x d e) <$> shrink c - , (\x -> Recipe a x c d e) <$> shrink b - , (\x -> Recipe x b c d e) <$> shrink a - ] - - ------------------------------------------------------------------------------- --- Creating Builders from basic encodings ------------------------------------------------------------------------------- - -testsEncodingToBuilder :: [Test] -testsEncodingToBuilder = - [ test_encodeUnfoldrF - , test_encodeUnfoldrB - - , compareImpls "encodeSize/Chunked/Size/Chunked (recipe)" - (testBuilder id) - ( - parseChunks parseHexLen . - parseSizePrefix parseHexLen . - parseChunks parseVar . - parseSizePrefix parseHexLen . - testBuilder ( - prefixHexSize . - encodeVar . - prefixHexSize . - encodeHex - ) - ) - - ] - - --- Unfoldr fused with encoding ------------------------------- - -test_encodeUnfoldrF :: Test -test_encodeUnfoldrF = - compareImpls "encodeUnfoldrF word8" id encode - where - toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty - encode = - L.unpack . toLBS . BE.encodeUnfoldrWithF BE.word8 go - where - go [] = Nothing - go (w:ws) = Just (w, ws) - - -test_encodeUnfoldrB :: Test -test_encodeUnfoldrB = - compareImpls "encodeUnfoldrB charUtf8" (concatMap charUtf8_list) encode - where - toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty - encode = - L.unpack . toLBS . BE.encodeUnfoldrWithB BE.charUtf8 go - where - go [] = Nothing - go (c:cs) = Just (c, cs) - - --- Chunked encoding and size prefix ------------------------------------ - -testBuilder :: (Builder -> Builder) -> Recipe -> L.ByteString -testBuilder f recipe = - toLBS (f b) - where - (b, toLBS) = recipeComponents $ clearTail recipe - -- need to remove tail of recipe to have a tighter - -- check on encodeWithSize - clearTail (Recipe how firstSize otherSize _ as) = - Recipe how firstSize otherSize L.empty as - --- | Chunked encoding using base-128, variable-length encoding for the --- chunk-size. -encodeVar :: Builder -> Builder -encodeVar = - (`mappend` BE.encodeWithF BE.word8 0) - . (BE.encodeChunked 5 BE.word64VarFixedBound BE.emptyB) - --- | Chunked encoding using 0-padded, space-terminated hexadecimal numbers --- for encoding the chunk-size. -encodeHex :: Builder -> Builder -encodeHex = - (`mappend` BE.encodeWithF (hexLen 0) 0) - . (BE.encodeChunked 7 hexLen BE.emptyB) - -hexLen :: Word64 -> BE.FixedEncoding Word64 -hexLen bound = - (\x -> (x, ' ')) BE.>$< (BE.word64HexFixedBound '0' bound BE.>*< BE.char8) - -parseHexLen :: [Word8] -> (Int, [Word8]) -parseHexLen ws = case span (/= 32) ws of - (lenWS, 32:ws') -> case readHex (map (chr . fromIntegral) lenWS) of - [(len, [])] -> (len, ws') - _ -> error $ "hex parse failed: " ++ show ws - (_, _) -> error $ "unterminated hex-length:" ++ show ws - -parseChunks :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString -parseChunks parseLen = - L.pack . go . L.unpack - where - go ws - | chunkLen == 0 = rest - | chunkLen <= length ws' = chunk ++ go rest - | otherwise = error $ "too few bytes: " ++ show ws - where - (chunkLen, ws') = parseLen ws - (chunk, rest) = splitAt chunkLen ws' - - --- | Prefix with size. We use an inner buffer size of 77 (almost primes are good) to --- get several buffer full signals. -prefixHexSize :: Builder -> Builder -prefixHexSize = BE.encodeWithSize 77 hexLen - -parseSizePrefix :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString -parseSizePrefix parseLen = - L.pack . go . L.unpack - where - go ws - | len <= length ws' = take len ws' - | otherwise = error $ "too few bytes: " ++ show (len, ws, ws') - where - (len, ws') = parseLen ws - - ------------------------------------------------------------------------------- --- Testing the Put monad ------------------------------------------------------------------------------- - -testPut :: Test -testPut = testGroup "Put monad" - [ testLaw "identity" (\v -> (pure id <*> putInt v) `eqPut` (putInt v)) - - , testLaw "composition" $ \(u, v, w) -> - (pure (.) <*> minusInt u <*> minusInt v <*> putInt w) `eqPut` - (minusInt u <*> (minusInt v <*> putInt w)) - - , testLaw "homomorphism" $ \(f, x) -> - (pure (f -) <*> pure x) `eqPut` (pure (f - x)) - - , testLaw "interchange" $ \(u, y) -> - (minusInt u <*> pure y) `eqPut` (pure ($ y) <*> minusInt u) - - , testLaw "ignore left value" $ \(u, v) -> - (putInt u *> putInt v) `eqPut` (pure (const id) <*> putInt u <*> putInt v) - - , testLaw "ignore right value" $ \(u, v) -> - (putInt u <* putInt v) `eqPut` (pure const <*> putInt u <*> putInt v) - - , testLaw "functor" $ \(f, x) -> - (fmap (f -) (putInt x)) `eqPut` (pure (f -) <*> putInt x) - - ] - where - putInt i = putBuilder (integerDec i) >> return i - minusInt i = (-) <$> putInt i - run p = toLazyByteString $ fromPut (do i <- p; _ <- putInt i; return ()) - eqPut p1 p2 = (run p1, run p2) - - testLaw name f = compareImpls name (fst . f) (snd . f) - - ------------------------------------------------------------------------------- --- Testing the Driver <-> Builder protocol ------------------------------------------------------------------------------- - --- | Ensure that there are at least 'n' free bytes for the following 'Builder'. -{-# INLINE ensureFree #-} -ensureFree :: Int -> Builder -ensureFree minFree = - BI.builder step - where - step k br@(BI.BufferRange op ope) - | ope `minusPtr` op < minFree = return $ BI.bufferFull minFree op next - | otherwise = k br - where - next br'@(BI.BufferRange op' ope') - | freeSpace < minFree = - error $ "ensureFree: requested " ++ show minFree ++ " bytes, " ++ - "but got only " ++ show freeSpace ++ " bytes" - | otherwise = k br' - where - freeSpace = ope' `minusPtr` op' - - ------------------------------------------------------------------------------- --- Testing the pre-defined builders ------------------------------------------------------------------------------- - -testBuilderConstr :: (Arbitrary a, Show a) - => TestName -> (a -> [Word8]) -> (a -> Builder) -> Test -testBuilderConstr name ref mkBuilder = - testProperty name check - where - check x = - (ws ++ ws) == - (L.unpack $ toLazyByteString $ mkBuilder x `mappend` mkBuilder x) - where - ws = ref x - - -testsBinary :: [Test] -testsBinary = - [ testBuilderConstr "word8" bigEndian_list word8 - , testBuilderConstr "int8" bigEndian_list int8 - - -- big-endian - , testBuilderConstr "int16BE" bigEndian_list int16BE - , testBuilderConstr "int32BE" bigEndian_list int32BE - , testBuilderConstr "int64BE" bigEndian_list int64BE - - , testBuilderConstr "word16BE" bigEndian_list word16BE - , testBuilderConstr "word32BE" bigEndian_list word32BE - , testBuilderConstr "word64BE" bigEndian_list word64BE - - , testBuilderConstr "floatLE" (float_list littleEndian_list) floatLE - , testBuilderConstr "doubleLE" (double_list littleEndian_list) doubleLE - - -- little-endian - , testBuilderConstr "int16LE" littleEndian_list int16LE - , testBuilderConstr "int32LE" littleEndian_list int32LE - , testBuilderConstr "int64LE" littleEndian_list int64LE - - , testBuilderConstr "word16LE" littleEndian_list word16LE - , testBuilderConstr "word32LE" littleEndian_list word32LE - , testBuilderConstr "word64LE" littleEndian_list word64LE - - , testBuilderConstr "floatBE" (float_list bigEndian_list) floatBE - , testBuilderConstr "doubleBE" (double_list bigEndian_list) doubleBE - - -- host dependent - , testBuilderConstr "int16Host" hostEndian_list int16Host - , testBuilderConstr "int32Host" hostEndian_list int32Host - , testBuilderConstr "int64Host" hostEndian_list int64Host - , testBuilderConstr "intHost" hostEndian_list intHost - - , testBuilderConstr "word16Host" hostEndian_list word16Host - , testBuilderConstr "word32Host" hostEndian_list word32Host - , testBuilderConstr "word64Host" hostEndian_list word64Host - , testBuilderConstr "wordHost" hostEndian_list wordHost - - , testBuilderConstr "floatHost" (float_list hostEndian_list) floatHost - , testBuilderConstr "doubleHost" (double_list hostEndian_list) doubleHost - ] - -testsASCII :: [Test] -testsASCII = - [ testBuilderConstr "char7" char7_list char7 - , testBuilderConstr "string7" (concatMap char7_list) string7 - - , testBuilderConstr "int8Dec" dec_list int8Dec - , testBuilderConstr "int16Dec" dec_list int16Dec - , testBuilderConstr "int32Dec" dec_list int32Dec - , testBuilderConstr "int64Dec" dec_list int64Dec - , testBuilderConstr "intDec" dec_list intDec - - , testBuilderConstr "word8Dec" dec_list word8Dec - , testBuilderConstr "word16Dec" dec_list word16Dec - , testBuilderConstr "word32Dec" dec_list word32Dec - , testBuilderConstr "word64Dec" dec_list word64Dec - , testBuilderConstr "wordDec" dec_list wordDec - - , testBuilderConstr "integerDec" dec_list integerDec - , testBuilderConstr "floatDec" dec_list floatDec - , testBuilderConstr "doubleDec" dec_list doubleDec - - , testBuilderConstr "word8Hex" hex_list word8Hex - , testBuilderConstr "word16Hex" hex_list word16Hex - , testBuilderConstr "word32Hex" hex_list word32Hex - , testBuilderConstr "word64Hex" hex_list word64Hex - , testBuilderConstr "wordHex" hex_list wordHex - - , testBuilderConstr "word8HexFixed" wordHexFixed_list word8HexFixed - , testBuilderConstr "word16HexFixed" wordHexFixed_list word16HexFixed - , testBuilderConstr "word32HexFixed" wordHexFixed_list word32HexFixed - , testBuilderConstr "word64HexFixed" wordHexFixed_list word64HexFixed - - , testBuilderConstr "int8HexFixed" int8HexFixed_list int8HexFixed - , testBuilderConstr "int16HexFixed" int16HexFixed_list int16HexFixed - , testBuilderConstr "int32HexFixed" int32HexFixed_list int32HexFixed - , testBuilderConstr "int64HexFixed" int64HexFixed_list int64HexFixed - - , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed - , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed - ] - -testsChar8 :: [Test] -testsChar8 = - [ testBuilderConstr "charChar8" char8_list char8 - , testBuilderConstr "stringChar8" (concatMap char8_list) string8 - ] - -testsUtf8 :: [Test] -testsUtf8 = - [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 - , testBuilderConstr "stringUtf8" (concatMap charUtf8_list) stringUtf8 - ] diff --git a/tests/builder/TestSuite.hs b/tests/builder/TestSuite.hs --- a/tests/builder/TestSuite.hs +++ b/tests/builder/TestSuite.hs @@ -2,8 +2,8 @@ --import Test.Framework (defaultMain, Test, testGroup) -import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Tests -import qualified Data.ByteString.Lazy.Builder.Tests +import qualified Data.ByteString.Builder.Tests +import qualified Data.ByteString.Builder.Prim.Tests import TestFramework @@ -12,10 +12,10 @@ tests :: [Test] tests = - [ testGroup "Data.ByteString.Lazy.Builder" - Data.ByteString.Lazy.Builder.Tests.tests + [ testGroup "Data.ByteString.Builder" + Data.ByteString.Builder.Tests.tests , testGroup "Data.ByteString.Lazy.Builder.BasicEncoding" - Data.ByteString.Lazy.Builder.BasicEncoding.Tests.tests + Data.ByteString.Builder.Prim.Tests.tests ]