bytestring-builder (empty) → 0.10.4.0

raw patch · 18 files changed

+5133/−0 lines, 18 filesdep +basedep +bytestringdep +deepseqbuild-type:Customsetup-changed

Dependencies added: base, bytestring, deepseq

Files

• LICENSE +30/−0
• Setup.hs +40/−0
• bytestring-builder.cabal +95/−0
• cbits/fpstring.c +9/−0
• cbits/itoa.c +215/−0
• src/Data/ByteString/Builder.hs +458/−0
• src/Data/ByteString/Builder/ASCII.hs +379/−0
• src/Data/ByteString/Builder/Extra.hs +212/−0
• src/Data/ByteString/Builder/Internal.hs +1133/−0
• src/Data/ByteString/Builder/Prim.hs +741/−0
• src/Data/ByteString/Builder/Prim/ASCII.hs +287/−0
• src/Data/ByteString/Builder/Prim/Binary.hs +336/−0
• src/Data/ByteString/Builder/Prim/Internal.hs +280/−0
• src/Data/ByteString/Builder/Prim/Internal/Base16.hs +77/−0
• src/Data/ByteString/Builder/Prim/Internal/Floating.hs +55/−0
• src/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs +111/−0
• src/Data/ByteString/Short.hs +85/−0
• src/Data/ByteString/Short/Internal.hs +590/−0

@@ -0,0 +1,30 @@+Copyright Jasper Van der Jeugt 2010, Simon Meier 2010-2013++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jasper Van der Jeugt nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,40 @@+import Distribution.Simple+import Distribution.Simple.Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import Distribution.Version++-- This checks the direct dependency of the bytestring package being+-- compiled against to set the bytestring_has_itoa_c and+-- bytestring_has_builder flags accordingly.++main = defaultMainWithHooks simpleUserHooks {+    confHook = \pkg flags ->+      if null (configConstraints flags)+      then do+        confHook simpleUserHooks pkg flags+      else do+        let bytestring_version =+                case [ versionBranch v+                     | (Dependency pkg ver)  <- configConstraints flags+                     , pkg == PackageName "bytestring"+                     , (Just v) <- [isSpecificVersion ver] ]+                  of+                     [v] -> v+                     vs   -> error ("error detecting bytestring version  "  ++ show vs)++        let has_itoa_c  = ( FlagName "bytestring_has_itoa_c"+                          , bytestring_version >= [0,10]      )++        let has_builder = ( FlagName "bytestring_has_builder"+                          , bytestring_version >= [0,10,4]   )++        let update fs gs =+                 fs ++ [ g | g <- gs, not $ any (\f -> fst f == fst g) fs]++        let flags' = flags { configConfigurationsFlags =+                                update [has_itoa_c, has_builder]+                                       (configConfigurationsFlags flags) }+            +        confHook simpleUserHooks pkg flags'+  }

@@ -0,0 +1,95 @@+name:                bytestring-builder+version:             0.10.4.0+synopsis:            The new bytestring builder, packaged outside of GHC+description:+  This is the bytestring builder that is debuting in bytestring-0.10.4.0, which+  should be shipping with GHC 7.8, probably late in 2013.  This builder has+  several nice simplifications and improvements, and more out-of-box+  functionality than the older blaze-builder.+  .+  Note that this package detects which version of bytestring you are compiling+  against,  and if you are compiling against bytestring-0.10.4 or later, will+  be an empty package.+  .+  This package lets the new interface and implementation be used with most+  older compilers without upgrading bytestring, which can be rather+  problematic.  In conjunction with blaze-builder-0.4 or later,  which+  offers an implementation of blaze-builder in terms of bytestring-builder,+  this should let most people try the new interface and implementation without+  causing undue compatibility problems with packages that depend on+  blaze-builder.+  .+  GHC 7.6 did debut an almost identical interface and implementation, but with+  slightly different module names and organization.   Trying to re-export/rename+  the builder provided with 7.6 did not turn out to be very practical,  because+  this interface includes new functions that rely on Builder internals,+  which are not exported in 7.6.  Furthermore, these module names should be+  deprecated in 7.10.+license:             BSD3+license-file:        LICENSE+author:              Simon Meier, Jasper Van der Jeugt+maintainer:          Leon P Smith <leon@melding-monads.com>+copyright:           (c) 2010 Jasper Van der Jeugt+                     (c) 2010-2013 Simon Meier+category:            Data+build-type:          Custom+extra-source-files:+                     cbits/*.c++                     src/Data/ByteString/*.hs+                     src/Data/ByteString/Builder/*.hs+                     src/Data/ByteString/Builder/Prim/*.hs+                     src/Data/ByteString/Builder/Prim/Internal/*.hs+                     src/Data/ByteString/Short/*.hs+cabal-version:       >=1.8++source-repository head+  type:     git+  location: http://github.com/lpsmith/bytestring-builder++source-repository this+  type:     git+  location: http://github.com/lpsmith/bytestring-builder+  tag:      v0.10.4.0++-- Note that these flags are set by Setup.hs++Flag bytestring_has_itoa_c+  default: True+  manual: True++Flag bytestring_has_builder+  default: True+  manual: True++library+  build-depends:     base == 4.* ,+                     bytestring >= 0.9 && < 1.0,+                     deepseq++  if !flag(bytestring_has_itoa_c)+      c-sources: cbits/itoa.c+++  if !flag(bytestring_has_builder)+      hs-source-dirs: src+      c-sources: cbits/fpstring.c+      exposed-modules:+                         Data.ByteString.Builder+                         Data.ByteString.Builder.Extra+                         Data.ByteString.Builder.Prim++                         -- perhaps only exposed temporarily+                         Data.ByteString.Builder.Internal+                         Data.ByteString.Builder.Prim.Internal++                         Data.ByteString.Short+                         Data.ByteString.Short.Internal++      other-modules:+                         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

@@ -0,0 +1,9 @@+#include <string.h>++/* This wrapper is here so that we can copy a sub-range of a ByteArray#.+   We cannot construct a pointer to the interior of an unpinned ByteArray#,+   except by doing an unsafe ffi call, and adjusting the pointer C-side. */+void * fps_memcpy_offsets(void       *dst, unsigned long dst_off,+                          const void *src, unsigned long src_off, size_t n) {+    return memcpy(dst + dst_off, src + src_off, n);+}

@@ -0,0 +1,215 @@+///////////////////////////////////////////////////////////////+// Encoding numbers using ASCII characters                   //+//                                                           //+// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html //+///////////////////////////////////////////////////////////////++#include <stdio.h>++// Decimal Encoding+///////////////////++static const char* digits = "0123456789abcdef";++// signed integers+char* _hs_bytestring_int_dec (int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    int x_tmp;++    // we cannot negate directly as  0 - (minBound :: Int) = minBound+    if (x < 0) {+        *ptr++ = '-';+        buf++;+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x * 10 - x_tmp];+        if (x == 0)+          return ptr;+        else+          x = -x;+    }++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}++// signed long long ints (64 bit integers)+char* _hs_bytestring_long_long_int_dec (long long int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    long long int x_tmp;++    // we cannot negate directly as  0 - (minBound :: Int) = minBound+    if (x < 0) {+        *ptr++ = '-';+        buf++;+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x * 10 - x_tmp];+        if (x == 0)+          return ptr;+        else+          x = -x;+    }++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}++// unsigned integers+char* _hs_bytestring_uint_dec (unsigned int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    unsigned int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}++// unsigned long ints+char* _hs_bytestring_long_long_uint_dec (long long unsigned int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    long long unsigned int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}+++// Padded, decimal, positive integers for the decimal output of bignums+///////////////////////////////////////////////////////////////////////++// Padded (9 digits), decimal, positive int:+// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than+// 10^9, as "31 * log 2 / log 10 = 9.33"+void _hs_bytestring_int_dec_padded9 (int x, char* buf)+{+    const int max_width_int32_dec = 9;+    char* ptr = buf + max_width_int32_dec;+    int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *(--ptr) = digits[x_tmp - x * 10];+    } while ( x );++    // pad beginning+    while (buf < ptr) { *(--ptr) = '0'; }+}++// Padded (19 digits), decimal, positive long long int:+// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than+// 10^18, as "63 * log 2 / log 10 = 18.96"+void _hs_bytestring_long_long_int_dec_padded18 (long long int x, char* buf)+{+    const int max_width_int64_dec = 18;+    char* ptr = buf + max_width_int64_dec;+    long long int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *(--ptr) = digits[x_tmp - x * 10];+    } while ( x );++    // pad beginning+    while (buf < ptr) { *(--ptr) = '0'; }+}+++///////////////////////+// Hexadecimal encoding+///////////////////////++// unsigned ints (32 bit words)+char* _hs_bytestring_uint_hex (unsigned int x, char* buf) {+    // write hex representation in reverse order+    char c, *ptr = buf, *next_free;+    do {+        *ptr++ = digits[x & 0xf];+        x >>= 4;+    } while ( x );+    // invert written digits+    next_free = ptr--;+    while(buf < ptr) {+        c      = *ptr;+        *ptr-- = *buf;+        *buf++ = c;+    }+    return next_free;+};++// unsigned long ints (64 bit words)+char* _hs_bytestring_long_long_uint_hex (long long unsigned int x, char* buf) {+    // write hex representation in reverse order+    char c, *ptr = buf, *next_free;+    do {+        *ptr++ = digits[x & 0xf];+        x >>= 4;+    } while ( x );+    // invert written digits+    next_free = ptr--;+    while(buf < ptr) {+        c      = *ptr;+        *ptr-- = *buf;+        *buf++ = c;+    }+    return next_free;+};

@@ -0,0 +1,458 @@+{-# LANGUAGE CPP, BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+{- | Copyright   : (c) 2010 Jasper Van der Jeugt+                   (c) 2010 - 2011 Simon Meier+License     : BSD3-style (see LICENSE)+Maintainer  : Simon Meier <iridcode@gmail.com>+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.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\\\"\", \"&#955;-w&#246;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 \'&#955;\'+and \'&#246;\' characters, which have a Unicode codepoint above 127, are+expanded to their corresponding UTF-8 multi-byte representation.++We use the @criterion@ library (<http://hackage.haskell.org/package/criterion>)+  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+    , shortByteString+    , 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           Data.ByteString.Builder.ASCII++import           Data.String (IsString(..))+import           System.IO (Handle)+import           Foreign++-- HADDOCK only imports+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++instance IsString Builder where+    fromString = stringUtf8

@@ -0,0 +1,379 @@+{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface,+             MagicHash, UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+-- | Copyright : (c) 2010 - 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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                           as L+import           Data.ByteString.Builder.Internal (Builder)+import qualified Data.ByteString.Builder.Prim                   as P++import           Foreign+++#if defined(__GLASGOW_HASKELL__) && defined(INTEGER_GMP)+import           Data.Monoid (mappend)+import           Foreign.C.Types++import qualified Data.ByteString.Builder.Prim.Internal          as P+import           Data.ByteString.Builder.Prim.Internal.UncheckedShifts+                   ( caseWordSize_32_64 )++import           GHC.Num     (quotRemInteger)+import           GHC.Types   (Int(..))+++# if __GLASGOW_HASKELL__ < 611+import GHC.Integer.Internals+# else+import GHC.Integer.GMP.Internals+# endif+#endif++------------------------------------------------------------------------------+-- 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+++-- 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+++------------------------------------------------------------------------------+-- Fast decimal 'Integer' encoding.+------------------------------------------------------------------------------++#if defined(__GLASGOW_HASKELL__) && defined(INTEGER_GMP)+-- An optimized version of the integer serialization code+-- in blaze-textual (c) 2011 MailRank, Inc. Bryan O'Sullivan+-- <bos@mailrank.com>. It is 2.5x faster on Int-sized integers and 4.5x faster+-- on larger integers.++# define PAIR(a,b) (# a,b #)++-- | Maximal power of 10 fitting into an 'Int' without using the MSB.+--     10 ^ 9  for 32 bit ints  (31 * log 2 / log 10 =  9.33)+--     10 ^ 18 for 64 bit ints  (63 * log 2 / log 10 = 18.96)+--+-- FIXME: Think about also using the MSB. For 64 bit 'Int's this makes a+-- difference.+maxPow10 :: Integer+maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18++-- | Decimal encoding of an 'Integer' using the ASCII digits.+integerDec :: Integer -> Builder+integerDec (S# i#) = intDec (I# i#)+integerDec i+    | i < 0     = P.primFixed P.char8 '-' `mappend` go (-i)+    | otherwise =                                   go ( i)+  where+    errImpossible fun =+        error $ "integerDec: " ++ fun ++ ": the impossible happened."++    go :: Integer -> Builder+    go n | n < maxPow10 = intDec (fromInteger n)+         | otherwise    =+             case putH (splitf (maxPow10 * maxPow10) n) of+               (x:xs) -> intDec x `mappend` P.primMapListBounded intDecPadded xs+               []     -> errImpossible "integerDec: go"++    splitf :: Integer -> Integer -> [Integer]+    splitf pow10 n0+      | pow10 > n0  = [n0]+      | otherwise   = splith (splitf (pow10 * pow10) n0)+      where+        splith []     = errImpossible "splith"+        splith (n:ns) =+            case n `quotRemInteger` pow10 of+                PAIR(q,r) | q > 0     -> q : r : splitb ns+                          | otherwise ->     r : splitb ns++        splitb []     = []+        splitb (n:ns) = case n `quotRemInteger` pow10 of+                            PAIR(q,r) -> q : r : splitb ns++    putH :: [Integer] -> [Int]+    putH []     = errImpossible "putH"+    putH (n:ns) = case n `quotRemInteger` maxPow10 of+                    PAIR(x,y)+                        | q > 0     -> q : r : putB ns+                        | otherwise ->     r : putB ns+                        where q = fromInteger x+                              r = fromInteger y++    putB :: [Integer] -> [Int]+    putB []     = []+    putB (n:ns) = case n `quotRemInteger` maxPow10 of+                    PAIR(q,r) -> fromInteger q : fromInteger r : putB ns+++foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9"+    c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO ()++foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18"+    c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO ()++{-# INLINE intDecPadded #-}+intDecPadded :: P.BoundedPrim Int+intDecPadded = P.liftFixedToBounded $ caseWordSize_32_64+    (P.fixedPrim  9 $ c_int_dec_padded9            . fromIntegral)+    (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral)++#else+-- compilers other than GHC++-- | Decimal encoding of an 'Integer' using the ASCII digits. Implemented+-- using via the 'Show' instance of 'Integer's.+integerDec :: Integer -> Builder+integerDec = string7 . show+#endif

@@ -0,0 +1,212 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- | Copyright : (c) 2010      Jasper Van der Jeugt+--               (c) 2010-2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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 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+    bytesWritten startPtr endPtr = endPtr `minusPtr` startPtr++    run :: I.BuildStep () -> BufferWriter+    run step = \buf len ->+      let doneH endPtr () =+            let !wc  = bytesWritten buf endPtr+                next = Done+             in return (wc, next)++          bufferFullH endPtr minReq step' =+            let !wc  = bytesWritten buf endPtr+                next = More minReq (run step')+             in return (wc, next)++          insertChunkH endPtr bs step' =+            let !wc  = bytesWritten buf endPtr+                next = Chunk bs (run step')+             in return (wc, next)++          br = I.BufferRange buf (buf `plusPtr` len)++      in I.fillWithBuildStep step doneH bufferFullH insertChunkH br++++------------------------------------------------------------------------------+-- 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+

@@ -0,0 +1,1133 @@+{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, RankNTypes #-}+#if __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Unsafe #-}+#endif+{-# OPTIONS_HADDOCK hide #-}+-- | Copyright : (c) 2010 - 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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 (+  -- * Buffer management+    Buffer(..)+  , BufferRange(..)+  , newBuffer+  , bufferSize+  , byteStringFromBuffer++  , ChunkIOStream(..)+  , buildStepToCIOS+  , ciosUnitToLazyByteString+  , ciosToLazyByteString++  -- * Build signals and steps+  , BuildSignal+  , BuildStep+  , finalBuildStep++  , done+  , bufferFull+  , insertChunk++  , fillWithBuildStep++  -- * The Builder monoid+  , Builder+  , builder+  , runBuilder+  , runBuilderWith++  -- ** Primitive combinators+  , empty+  , append+  , flush+  , ensureFree+  -- , sizedChunksInsert++  , byteStringCopy+  , byteStringInsert+  , byteStringThreshold++  , lazyByteStringCopy+  , lazyByteStringInsert+  , lazyByteStringThreshold+  +  , shortByteString++  , maximalCopySize+  , byteString+  , lazyByteString++  -- ** Execution+  , toLazyByteStringWith+  , AllocationStrategy+  , safeStrategy+  , untrimmedStrategy+  , customStrategy+  , L.smallChunkSize+  , L.defaultChunkSize+  , L.chunkOverhead++  -- * The Put monad+  , Put+  , put+  , runPut++  -- ** Execution+  , putToLazyByteString+  , putToLazyByteStringWith+  , hPut++  -- ** Conversion to and from Builders+  , putBuilder+  , fromPut++  -- -- ** Lifting IO actions+  -- , putLiftIO++) where++import           Control.Arrow (second)+import           Control.Applicative (Applicative(..), (<$>))+-- import           Control.Exception (return)++import           Data.Monoid+import qualified Data.ByteString               as S+import qualified Data.ByteString.Internal      as S+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString.Short.Internal as Sh++#if __GLASGOW_HASKELL__ >= 611+import qualified GHC.IO.Buffer as IO (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)+#if MIN_VERSION_base(4,7,0)+import           Foreign+#else+import           Foreign hiding (unsafeForeignPtrToPtr)+#endif+import           Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import           System.IO.Unsafe (unsafeDupablePerformIO)+#else+import           Foreign+import           GHC.IO (unsafeDupablePerformIO)+#endif++------------------------------------------------------------------------------+-- Buffers+------------------------------------------------------------------------------+-- | 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++-- | A 'Buffer' together with the 'BufferRange' of free bytes. The filled+-- space starts at offset 0 and ends at the first free byte.+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)+                     {-# UNPACK #-} !BufferRange+++-- | Combined size of the filled and free space in the buffer.+{-# INLINE bufferSize #-}+bufferSize :: Buffer -> Int+bufferSize (Buffer fpbuf (BufferRange _ ope)) =+    ope `minusPtr` unsafeForeignPtrToPtr fpbuf++-- | Allocate a new buffer of the given size.+{-# INLINE newBuffer #-}+newBuffer :: Int -> IO Buffer+newBuffer size = do+    fpbuf <- S.mallocByteString size+    let pbuf = unsafeForeignPtrToPtr fpbuf+    return $! Buffer fpbuf (BufferRange pbuf (pbuf `plusPtr` size))++-- | Convert the filled part of a 'Buffer' to a strict 'S.ByteString'.+{-# INLINE byteStringFromBuffer #-}+byteStringFromBuffer :: Buffer -> S.ByteString+byteStringFromBuffer (Buffer fpbuf (BufferRange op _)) =+    S.PS fpbuf 0 (op `minusPtr` unsafeForeignPtrToPtr fpbuf)++--- | Prepend the filled part of a 'Buffer' to a lazy 'L.ByteString'+--- trimming it if necessary.+{-# INLINE trimmedChunkFromBuffer #-}+trimmedChunkFromBuffer :: AllocationStrategy -> Buffer+                       -> L.ByteString -> L.ByteString+trimmedChunkFromBuffer (AllocationStrategy _ _ trim) buf k+  | S.null bs                           = k+  | trim (S.length bs) (bufferSize buf) = L.Chunk (S.copy bs) k+  | otherwise                           = L.Chunk bs          k+  where+    bs = byteStringFromBuffer buf++------------------------------------------------------------------------------+-- Chunked IO Stream+------------------------------------------------------------------------------++-- | A stream of chunks that are constructed in the 'IO' monad.+--+-- This datatype serves as the common interface for the buffer-by-buffer+-- execution of a 'BuildStep' by 'buildStepToCIOS'. Typical users of this+-- interface are 'ciosToLazyByteString' or iteratee-style libraries like+-- @enumerator@.+data ChunkIOStream a =+       Finished Buffer a+       -- ^ The partially filled last buffer together with the result.+     | Yield1 S.ByteString (IO (ChunkIOStream a))+       -- ^ Yield a /non-empty/ strict 'S.ByteString'.++-- | A smart constructor for yielding one chunk that ignores the chunk if+-- it is empty.+{-# INLINE yield1 #-}+yield1 :: S.ByteString -> IO (ChunkIOStream a) -> IO (ChunkIOStream a)+yield1 bs cios | S.null bs = cios+               | otherwise = return $ Yield1 bs cios++-- | Convert a @'ChunkIOStream' ()@ to a lazy 'L.ByteString' using+-- 'unsafeDupablePerformIO'.+{-# INLINE ciosUnitToLazyByteString #-}+ciosUnitToLazyByteString :: AllocationStrategy+                         -> L.ByteString -> ChunkIOStream () -> L.ByteString+ciosUnitToLazyByteString strategy k = go+  where+    go (Finished buf _) = trimmedChunkFromBuffer strategy buf k+    go (Yield1 bs io)   = L.Chunk bs $ unsafeDupablePerformIO (go <$> io)++-- | Convert a 'ChunkIOStream' to a lazy tuple of the result and the written+-- 'L.ByteString' using 'unsafeDupablePerformIO'.+{-# INLINE ciosToLazyByteString #-}+ciosToLazyByteString :: AllocationStrategy+                     -> (a -> (b, L.ByteString))+                     -> ChunkIOStream a+                     -> (b, L.ByteString)+ciosToLazyByteString strategy k =+    go+  where+    go (Finished buf x) =+        second (trimmedChunkFromBuffer strategy buf) $ k x+    go (Yield1 bs io)   = second (L.Chunk bs) $ unsafeDupablePerformIO (go <$> io)++------------------------------------------------------------------------------+-- Build signals+------------------------------------------------------------------------------++-- | 'BuildStep's may be called *multiple times* and they must not rise an+-- async. exception.+type BuildStep a = BufferRange -> IO (BuildSignal a)++-- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are+-- three signals: 'done', 'bufferFull', or 'insertChunks signals+data BuildSignal a =+    Done {-# UNPACK #-} !(Ptr Word8) a+  | BufferFull+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !(Ptr Word8)+                     (BuildStep a)+  | InsertChunk+      {-# UNPACK #-} !(Ptr Word8)+                     S.ByteString+                     (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+++-- | Signal that a 'S.ByteString' chunk should be inserted directly.+{-# INLINE insertChunk #-}+insertChunk :: Ptr Word8+            -- ^ Next free byte in current 'BufferRange'+            -> S.ByteString+            -- ^ Chunk to insert.+            -> BuildStep a+            -- ^ 'BuildStep' to run on next 'BufferRange'+            -> BuildSignal a+insertChunk op bs = InsertChunk op bs+++-- | 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 -> S.ByteString -> BuildStep a -> IO b)+    -- ^ Handling the 'insertChunk' signal+    -> BufferRange+    -- ^ Buffer range to fill.+    -> IO b+    -- ^ Value computed while 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+        InsertChunk op bs nextStep     -> fChunk op bs 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 with equally sized 'BufferRange's must result in the+        -- same sequence of bytes being written. If you need mutable state,+        -- then you must allocate it anew 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++-- | The final build step that returns the 'done' signal.+finalBuildStep :: BuildStep ()+finalBuildStep !(BufferRange op _) = return $ Done op ()++-- | Run a 'Builder' with the 'finalBuildStep'.+{-# INLINE runBuilder #-}+runBuilder :: Builder      -- ^ 'Builder' to run+           -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this+                           -- 'Builder' and signals 'done' upon completion.+runBuilder b = runBuilderWith b finalBuildStep++-- | 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 $ insertChunk op S.empty 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. The typical use case is the+-- implementation of an encoding that might fail (e.g., an interface to the+-- 'zlib' compression library or the conversion from Base64 encoded data to+-- 8-bit data). For a 'Builder', the only way to handle and report such a+-- failure is ignore it or call 'error'.  In contrast, 'Put' actions are+-- expressive enough to allow reportng and handling such a failure in a pure+-- fashion.+--+-- @'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 sequencing them is slightly cheaper than sequencing+-- 'Put's because they do not carry around 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' signals.+       --+    -- This function must be referentially transparent; i.e., calling it+    -- multiple times with equally sized 'BufferRange's 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 anew+    -- 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 #-}++-- | Synonym for '<*' from 'Applicative'; used in rewriting rules.+{-# INLINE[1] ap_l #-}+ap_l :: Put a -> Put b -> Put a+ap_l (Put a) (Put b) = Put $ \k -> a (\a' -> b (\_ -> k a'))++-- | Synonym for '*>' from 'Applicative' and '>>' from 'Monad'; used in+-- rewriting rules.+{-# INLINE[1] ap_r #-}+ap_r :: Put a -> Put b -> Put b+ap_r (Put a) (Put b) = Put $ \k -> a (\_ -> b k)++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 (<*) #-}+  (<*) = ap_l+  {-# INLINE (*>) #-}+  (*>) = ap_r+#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 (>>) #-}+  (>>) = ap_r+++-- Conversion between Put and Builder+-------------------------------------++-- | Run a 'Builder' as a side-effect of a @'Put' ()@ action.+{-# INLINE[1] 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)++-- We rewrite consecutive uses of 'putBuilder' such that the append of the+-- involved 'Builder's is used. This can significantly improve performance,+-- when the bound-checks of the concatenated builders are fused.++-- ap_l rules+{-# RULES++"ap_l/putBuilder" forall b1 b2.+       ap_l (putBuilder b1) (putBuilder b2)+     = putBuilder (append b1 b2)++"ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+       ap_l (putBuilder b1) (ap_l (putBuilder b2) p)+     = ap_l (putBuilder (append b1 b2)) p++"ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+       ap_l (ap_l p (putBuilder b1)) (putBuilder b2)+     = ap_l p (putBuilder (append b1 b2))+ #-}++-- ap_r rules+{-# RULES++"ap_r/putBuilder" forall b1 b2.+       ap_r (putBuilder b1) (putBuilder b2)+     = putBuilder (append b1 b2)++"ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+       ap_r (putBuilder b1) (ap_r (putBuilder b2) p)+     = ap_r (putBuilder (append b1 b2)) p++"ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+       ap_r (ap_r p (putBuilder b1)) (putBuilder b2)+     = ap_r p (putBuilder (append b1 b2))++ #-}++-- combined ap_l/ap_r rules+{-# RULES++"ap_l/ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+       ap_l (putBuilder b1) (ap_r (putBuilder b2) p)+     = ap_l (putBuilder (append b1 b2)) p++"ap_r/ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+       ap_r (putBuilder b1) (ap_l (putBuilder b2) p)+     = ap_l (putBuilder (append b1 b2)) p++"ap_l/ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+       ap_l (ap_r p (putBuilder b1)) (putBuilder b2)+     = ap_r p (putBuilder (append b1 b2))++"ap_r/ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+       ap_r (ap_l p (putBuilder b1)) (putBuilder b2)+     = ap_r p (putBuilder (append b1 b2))++ #-}+++-- 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 interuptible 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.+        --+        --      FIXME (SM): Adapt this function or at least its documentation,+        --      as it is OK to run a 'BuildStep' twice. We dropped this+        --      requirement in favor of being able to use+        --      'unsafeDupablePerformIO' and the speed improvement that it+        --      brings.+        --+        --   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 = IO.bufSize buf - IO.bufR buf++            makeSpace buf+              | IO.bufSize buf < minFree = do+                  flushWriteBuffer h_+                  s <- IO.bufState <$> readIORef refBuf+                  IO.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` IO.bufSize buf)+                  res <- fillWithBuildStep step doneH fullH insertChunkH br+                  touchForeignPtr fpBuf+                  return res+              where+                fpBuf = IO.bufRaw buf+                pBuf  = unsafeForeignPtrToPtr fpBuf+                op    = pBuf `plusPtr` IO.bufR buf++                {-# INLINE updateBufR #-}+                updateBufR op' = do+                    let !off' = op' `minusPtr` pBuf+                        !buf' = buf {IO.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'.++                insertChunkH op' bs nextStep = do+                    updateBufR op'+                    return $ do+                        S.hPut h bs+                        fillHandle 1 nextStep+#else+hPut h p =+    go =<< buildStepToCIOS strategy (runPut p)+  where+    strategy = untrimmedStrategy L.smallChunkSize L.defaultChunkSize++    go (Finished buf x) = S.hPut h (byteStringFromBuffer buf) >> return x+    go (Yield1 bs io)   = S.hPut h bs >> io >>= go+#endif++-- | Execute a 'Put' and return the computed result and the bytes+-- written during the computation as a lazy 'L.ByteString'.+--+-- This function is strict in the computed result and lazy in the writing of+-- the bytes. For example, given+--+-- @+--infinitePut = sequence_ (repeat (putBuilder (word8 1))) >> return 0+-- @+--+-- evaluating the expression+--+-- @+--fst $ putToLazyByteString infinitePut+-- @+--+-- does not terminate, while evaluating the expression+--+-- @+--L.head $ snd $ putToLazyByteString infinitePut+-- @+--+-- does terminate and yields the value @1 :: Word8@.+--+-- An illustrative example for these strictness properties is the+-- implementation of Base64 decoding (<http://en.wikipedia.org/wiki/Base64>).+--+-- @+--type DecodingState = ...+--+--decodeBase64 :: 'S.ByteString' -> DecodingState -> 'Put' (Maybe DecodingState)+--decodeBase64 = ...+-- @+--+-- The above function takes a strict 'S.ByteString' supposed to represent+-- Base64 encoded data and the current decoding state.+-- It writes the decoded bytes as the side-effect of the 'Put' and returns the+-- new decoding state, if the decoding of all data in the 'S.ByteString' was+-- successful. The checking if the strict 'S.ByteString' represents Base64+-- encoded data and the actual decoding are fused. This makes the common case,+-- where all data represents Base64 encoded data, more efficient. It also+-- implies that all data must be decoded before the final decoding+-- state can be returned. 'Put's are intended for implementing such fused+-- checking and decoding/encoding, which is reflected in their strictness+-- properties.+{-# NOINLINE putToLazyByteString #-}+putToLazyByteString+    :: Put a              -- ^ 'Put' to execute+    -> (a, L.ByteString)  -- ^ Result and lazy 'L.ByteString'+                          -- written as its side-effect+putToLazyByteString = putToLazyByteStringWith+    (safeStrategy L.smallChunkSize L.defaultChunkSize) (\x -> (x, L.Empty))+++-- | Execute a 'Put' with a buffer-allocation strategy and a continuation. For+-- example, 'putToLazyByteString' is implemented as follows.+--+-- @+--putToLazyByteString = 'putToLazyByteStringWith'+--    ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') (\x -> (x, L.empty))+-- @+--+{-# INLINE putToLazyByteStringWith #-}+putToLazyByteStringWith+    :: AllocationStrategy+       -- ^ Buffer allocation strategy to use+    -> (a -> (b, L.ByteString))+       -- ^ Continuation to use for computing the final result and the tail of+       -- its side-effect (the written bytes).+    -> Put a+       -- ^ 'Put' to execute+    -> (b, L.ByteString)+       -- ^ Resulting lazy 'L.ByteString'+putToLazyByteStringWith strategy k p =+    ciosToLazyByteString strategy k $ unsafeDupablePerformIO $+        buildStepToCIOS strategy (runPut p)++++------------------------------------------------------------------------------+-- 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.+wrappedBytesCopyStep :: BufferRange  -- ^ Input 'BufferRange'.+                     -> BuildStep a -> BuildStep a+wrappedBytesCopyStep !(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 $ insertChunk op 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 br0@(BufferRange op ope)+    -- Ensure that the common case is not recursive and therefore yields+    -- better code.+    | op' <= ope = do copyBytes op ip isize+                      touchForeignPtr ifp+                      k0 (BufferRange op' ope)+    | otherwise  = do wrappedBytesCopyStep (BufferRange ip ipe) k br0+  where+    op'  = op `plusPtr` isize+    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 $ \k (BufferRange op _) -> return $ insertChunk op bs k++-- Short bytestrings+------------------------------------------------------------------------------++-- | Construct a 'Builder' that copies the 'SH.ShortByteString'.+--+{-# INLINE shortByteString #-}+shortByteString :: Sh.ShortByteString -> Builder+shortByteString = \sbs -> builder $ shortByteStringCopyStep sbs++-- | Copy the bytes from a 'SH.ShortByteString' into the output stream.+{-# INLINE shortByteStringCopyStep #-}+shortByteStringCopyStep :: Sh.ShortByteString  -- ^ Input 'SH.ShortByteString'.+                        -> BuildStep a -> BuildStep a+shortByteStringCopyStep !sbs k =+    go 0 (Sh.length sbs)+  where+    go !ip !ipe !(BufferRange op ope)+      | inpRemaining <= outRemaining = do+          Sh.copyToPtr sbs ip op inpRemaining+          let !br' = BufferRange (op `plusPtr` inpRemaining) ope+          k br'+      | otherwise = do+          Sh.copyToPtr sbs ip op outRemaining+          let !ip' = ip + outRemaining+          return $ bufferFull 1 ope (go ip' ipe)+      where+        outRemaining = ope `minusPtr` op+        inpRemaining = ipe - ip+++-- 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 =+    L.foldrChunks (\bs b -> byteStringInsert bs `mappend` b) mempty++-- | 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++------------------------------------------------------------------------------+-- 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+         (Maybe (Buffer, Int) -> IO Buffer)+         {-# UNPACK #-} !Int+         (Int -> Int -> Bool)++-- | Create a custom allocation strategy. See the code for 'safeStrategy' and+-- 'untrimmedStrategy' for examples.+{-# INLINE customStrategy #-}+customStrategy+  :: (Maybe (Buffer, Int) -> IO Buffer)+     -- ^ Buffer allocation function. If 'Nothing' is given, then a new first+     -- buffer should be allocated. If @'Just' (oldBuf, minSize)@ is given,+     -- then a buffer with minimal size 'minSize' must be returned. The+     -- strategy may reuse the 'oldBuffer', if it can guarantee that this+     -- referentially transparent and 'oldBuffer' is large enough.+  -> Int+     -- ^ Default buffer size.+  -> (Int -> Int -> Bool)+     -- ^ A predicate @trim used allocated@ returning 'True', if the buffer+     -- should be trimmed before it is returned.+  -> AllocationStrategy+customStrategy = AllocationStrategy++-- | Sanitize a buffer size; i.e., make it at least the size of an '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 nextBuffer (sanitize bufSize) (\_ _ -> False)+  where+    {-# INLINE nextBuffer #-}+    nextBuffer Nothing             = newBuffer $ sanitize firstSize+    nextBuffer (Just (_, minSize)) = newBuffer minSize+++-- | 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 nextBuffer (sanitize bufSize) trim+  where+    trim used size                 = 2 * used < size+    {-# INLINE nextBuffer #-}+    nextBuffer Nothing             = newBuffer $ sanitize firstSize+    nextBuffer (Just (_, minSize)) = newBuffer minSize++-- | /Heavy inlining./ Execute a 'Builder' with custom execution parameters.+--+-- This function is inlined despite its heavy code-size to allow fusing with+-- the allocation strategy. For example, the default 'Builder' execution+-- function 'toLazyByteString' is defined as follows.+--+-- @+-- {-\# NOINLINE toLazyByteString \#-}+-- toLazyByteString =+--   toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') L.empty+-- @+--+-- where @L.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) L.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 and less than 128 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 =+    ciosUnitToLazyByteString strategy k $ unsafeDupablePerformIO $+        buildStepToCIOS strategy (runBuilder b)++-- | Convert a 'BuildStep' to a 'ChunkIOStream' stream by executing it on+-- 'Buffer's allocated according to the given 'AllocationStrategy'.+{-# INLINE buildStepToCIOS #-}+buildStepToCIOS+    :: AllocationStrategy          -- ^ Buffer allocation strategy to use+    -> BuildStep a                 -- ^ 'BuildStep' to execute+    -> IO (ChunkIOStream a)+buildStepToCIOS !(AllocationStrategy nextBuffer bufSize trim) =+    \step -> nextBuffer Nothing >>= fill step+  where+    fill !step !buf@(Buffer fpbuf br@(BufferRange _ pe)) = do+        res <- fillWithBuildStep step doneH fullH insertChunkH br+        touchForeignPtr fpbuf+        return res+      where+        pbuf = unsafeForeignPtrToPtr fpbuf++        doneH op' x = return $+            Finished (Buffer fpbuf (BufferRange op' pe)) x++        fullH op' minSize nextStep =+            wrapChunk op' $ const $+                nextBuffer (Just (buf, max minSize bufSize)) >>= fill nextStep++        insertChunkH op' bs nextStep =+            wrapChunk op' $ \isEmpty -> yield1 bs $+                -- Checking for empty case avoids allocating 'n-1' empty+                -- buffers for 'n' insertChunkH right after each other.+                if isEmpty+                  then fill nextStep buf+                  else do buf' <- nextBuffer (Just (buf, bufSize))+                          fill nextStep buf'++        -- Wrap and yield a chunk, trimming it if necesary+        {-# INLINE wrapChunk #-}+        wrapChunk !op' mkCIOS+          | chunkSize == 0      = mkCIOS True+          | trim chunkSize size = do+              bs <- S.create chunkSize $ \pbuf' ->+                        copyBytes pbuf' pbuf chunkSize+              -- FIXME: We could reuse the trimmed buffer here.+              return $ Yield1 bs (mkCIOS False)+          | otherwise            =+              return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False)+          where+            chunkSize = op' `minusPtr` pbuf+            size      = pe  `minusPtr` pbuf

@@ -0,0 +1,741 @@+{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+{- | Copyright : (c) 2010-2011 Simon Meier+                 (c) 2010      Jasper van der Jeugt+License        : BSD3-style (see LICENSE)+Maintainer     : Simon Meier <iridcode@gmail.com>+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.+<http://hackage.haskell.org/cgi-bin/hackage-scripts/package/dlist>. )+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'+    &#160;+    {&#45;\# INLINE fixed2 \#&#45;}+    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\\\"\", \"&#955;-w&#246;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 \'>\'.++@+{&#45;\# INLINE charUtf8HtmlEscaped \#&#45;}+charUtf8HtmlEscaped :: E.BoundedPrim Char+charUtf8HtmlEscaped =+    'condB' (>  \'\>\' ) E.'charUtf8' $+    'condB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $        -- &lt;+    'condB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $        -- &gt;+    'condB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $  -- &amp;+    'condB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $  -- &\#34;+    'condB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $  -- &\#39;+    ('liftFixedToBounded' E.'char7')         -- fallback for 'Char's smaller than \'\>\'+  where+    {&#45;\# INLINE fixed4 \#&#45;}+    fixed4 x = 'liftFixedToBounded' $ const x '>$<'+      E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7+    &#160;+    {&#45;\# INLINE fixed5 \#&#45;}+    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 (<http://hackage.haskell.org/package/bytestring>). 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 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)+#if MIN_VERSION_base(4,7,0)+import           Foreign+#else+import           Foreign hiding (unsafeForeignPtrToPtr)+#endif+import           Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+#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 x =+    -- It is important to avoid recursive 'BuildStep's where possible, as+    -- their closure allocation is expensive. Using 'ensureFree' allows the+    -- 'step' to assume that at least 'sizeBound w' free space is available.+    ensureFree (I.sizeBound w) `mappend` builder step+  where+    step k (BufferRange op ope) = do+        op' <- runB w x op+        let !br' = BufferRange op' ope+        k br'++{-# 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 xs0 =+    builder $ step xs0+  where+    step xs1 k (BufferRange op0 ope0) =+        go xs1 op0+      where+        go []          !op             = k (BufferRange op ope0)+        go xs@(x':xs') !op+          | op `plusPtr` bound <= ope0 = runB w x' op >>= go xs'+          | otherwise                  =+             return $ bufferFull bound op (step xs k)++    bound = I.sizeBound w++-- 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 f x0 =+    builder $ fillWith x0+  where+    fillWith x k !(BufferRange op0 ope0) =+        go (f x) op0+      where+        go !Nothing        !op         = do let !br' = BufferRange op ope0+                                            k br'+        go !(Just (y, x')) !op+          | op `plusPtr` bound <= ope0 = runB w y op >>= go (f x')+          | otherwise                  = return $ bufferFull bound op $+              \(BufferRange opNew opeNew) -> do+                  !opNew' <- runB w y opNew+                  fillWith x' k (BufferRange opNew' opeNew)+    bound = I.sizeBound w++-- | 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 = boudedPrim 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++

@@ -0,0 +1,287 @@+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-}+-- | Copyright   : (c) 2010 Jasper Van der Jeugt+--                 (c) 2010 - 2011 Simon Meier+-- License       : BSD3-style (see LICENSE)+--+-- Maintainer    : Simon Meier <iridcode@gmail.com>+-- 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 = boudedPrim 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 = boudedPrim 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 = boudedPrim 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 = boudedPrim 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 =+    boudedPrim (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 = boudedPrim 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 = fixedPrim 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++

@@ -0,0 +1,336 @@+{-# LANGUAGE CPP, BangPatterns #-}+-- | Copyright   : (c) 2010-2011 Simon Meier+-- License       : BSD3-style (see LICENSE)+--+-- Maintainer    : Simon Meier <iridcode@gmail.com>+-- 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 = fixedPrim 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 = fixedPrim 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 = fixedPrim 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 = fixedPrim 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 = fixedPrim 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 =+    fixedPrim 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 = fixedPrim 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 =+    fixedPrim 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 = fixedPrim 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++

@@ -0,0 +1,280 @@+{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-}+#if __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Unsafe #-}+#endif+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Copyright   : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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+  , fixedPrim+  , size+  , runF++  , emptyF+  , contramapF+  , pairF+  -- , liftIOF++  , storableToF++  -- * Bounded-size builder primitives+  , BoundedPrim+  , boudedPrim+  , 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 = FP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ())++fixedPrim :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a+fixedPrim = FP++-- | The size of the sequences of bytes generated by this 'FixedPrim'.+{-# INLINE CONLIKE size #-}+size :: FixedPrim a -> Int+size (FP l _) = l++{-# INLINE CONLIKE runF #-}+runF :: FixedPrim a -> a -> Ptr Word8 -> IO ()+runF (FP _ io) = io++-- | The 'FixedPrim' that always results in the zero-length sequence.+{-# INLINE CONLIKE emptyF #-}+emptyF :: FixedPrim a+emptyF = FP 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 (FP l1 io1) (FP l2 io2) =+    FP (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'+-- <http://hackage.haskell.org/package/contravariant>. 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 (FP l io) = FP l (\x op -> io (f x) op)++-- | Convert a 'FixedPrim' to a 'BoundedPrim'.+{-# INLINE CONLIKE toB #-}+toB :: FixedPrim a -> BoundedPrim a+toB (FP l io) = BP 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 = FP (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x)++{-+{-# INLINE CONLIKE liftIOF #-}+liftIOF :: FixedPrim a -> FixedPrim (IO a)+liftIOF (FP l io) = FP 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 = BP {-# 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 (BP b _) = b++boudedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a+boudedPrim = BP++{-# INLINE CONLIKE runB #-}+runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)+runB (BP _ io) = io++-- | Change a 'BoundedPrim' such that it first applies a function to the+-- value to be encoded.+--+-- Note that 'BoundedPrim's are 'Contrafunctors'+-- <http://hackage.haskell.org/package/contravariant>. 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 (BP b io) = BP b (\x op -> io (f x) op)++-- | The 'BoundedPrim' that always results in the zero-length sequence.+{-# INLINE CONLIKE emptyB #-}+emptyB :: BoundedPrim a+emptyB = BP 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 (BP b1 io1) (BP b2 io2) =+    BP (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 (BP b1 io1) (BP b2 io2) =+    BP (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)

@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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+  , lowerTable+  , encode8_as_16h+  ) where++import qualified Data.ByteString          as S+import qualified Data.ByteString.Internal as S++#if MIN_VERSION_base(4,4,0)+#if MIN_VERSION_base(4,7,0)+import           Foreign+#else+import           Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr)+#endif+import           Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import           System.IO.Unsafe (unsafePerformIO)+#else+import           Foreign+#endif++-- Creating the encoding table+------------------------------++-- 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 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++-- | 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

@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Copyright   : (c) 2010 Simon Meier+--+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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 = fixedPrim (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 = fixedPrim (size w64fe) $ \x op -> do+      poke (castPtr op) x+      x' <- peek (castPtr op)+      runF w64fe x' op+

@@ -0,0 +1,111 @@+{-# 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 <iridcode@gmail.com>+-- 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 =+#if MIN_VERSION_base(4,7,0)+  case finiteBitSize (undefined :: Word) of+#else+  case bitSize (undefined :: Word) of+#endif+    32 -> f32+    64 -> f64+    s  -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s++

@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-- |+-- Module      : Data.ByteString.Short+-- Copyright   : (c) Duncan Coutts 2012-2013+-- License     : BSD-style+--+-- Maintainer  : duncan@community.haskell.org+-- Stability   : stable+-- Portability : ghc only+-- +-- A compact representation suitable for storing short byte strings in memory.+--+-- In typical use cases it can be imported alongside "Data.ByteString", e.g.+--+-- > import qualified Data.ByteString       as B+-- > import qualified Data.ByteString.Short as B+-- >          (ShortByteString, toShort, fromShort)+--+-- Other 'ShortByteString' operations clash with "Data.ByteString" or "Prelude"+-- functions however, so they should be imported @qualified@ with a different+-- alias e.g.+--+-- > import qualified Data.ByteString.Short as B.Short+--+module Data.ByteString.Short (++    -- * The @ShortByteString@ type++    ShortByteString,++    -- ** Memory overhead+    -- | With GHC, the memory overheads are as follows, expressed in words and+    -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively).+    --+    -- * 'ByteString' unshared: 9 words; 36 or 72 bytes.+    --+    -- * 'ByteString' shared substring: 5 words; 20 or 40 bytes.+    --+    -- * 'ShortByteString': 4 words; 16 or 32 bytes.+    --+    -- For the string data itself, both 'ShortByteString' and 'ByteString' use+    -- one byte per element, rounded up to the nearest word. For example,+    -- including the overheads, a length 10 'ShortByteString' would take+    -- @16 + 12 = 28@ bytes on a 32bit platform and @32 + 16 = 48@ bytes on a+    -- 64bit platform.+    --+    -- These overheads can all be reduced by 1 word (4 or 8 bytes) when the+    -- 'ShortByteString' or 'ByteString' is unpacked into another constructor.+    --+    -- For example:+    --+    -- > data ThingId = ThingId {-# UNPACK #-} !Int+    -- >                        {-# UNPACK #-} !ShortByteString+    --+    -- This will take @1 + 1 + 3@ words (the @ThingId@ constructor ++    -- unpacked @Int@ + unpacked @ShortByteString@), plus the words for the+    -- string data.+    +    -- ** Heap fragmentation+    -- | With GHC, the 'ByteString' representation uses /pinned/ memory,+    -- meaning it cannot be moved by the GC. This is usually the right thing to+    -- do for larger strings, but for small strings using pinned memory can+    -- lead to heap fragmentation which wastes space. The 'ShortByteString'+    -- type (and the @Text@ type from the @text@ package) use /unpinned/ memory+    -- so they do not contribute to heap fragmentation. In addition, with GHC,+    -- small unpinned strings are allocated in the same way as normal heap+    -- allocations, rather than in a separate pinned area.++    -- * Conversions+    toShort,+    fromShort,+    pack,+    unpack,++    -- * Other operations+    empty, null, length, index,+  ) where++import Data.ByteString.Short.Internal+import Prelude ()+

@@ -0,0 +1,590 @@+{-# LANGUAGE DeriveDataTypeable, CPP, BangPatterns, RankNTypes,+             ForeignFunctionInterface, MagicHash, UnboxedTuples,+             UnliftedFFITypes #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+#if __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Unsafe #-}+#endif+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module      : Data.ByteString.Short.Internal+-- Copyright   : (c) Duncan Coutts 2012-2013+-- License     : BSD-style+--+-- Maintainer  : duncan@community.haskell.org+-- Stability   : stable+-- Portability : ghc only+-- +-- Internal representation of ShortByteString+--+module Data.ByteString.Short.Internal (++    -- * The @ShortByteString@ type and representation+    ShortByteString(..),++    -- * Conversions+    toShort,+    fromShort,+    pack,+    unpack,++    -- * Other operations+    empty, null, length, index, unsafeIndex,++    -- * Low level operations+    createFromPtr, copyToPtr+  ) where++import Data.ByteString.Internal (ByteString(..), inlinePerformIO)++import Data.Typeable    (Typeable)+import Data.Data        (Data(..), mkNoRepType)+import Data.Monoid      (Monoid(..))+import Data.String      (IsString(..))+import Control.DeepSeq  (NFData(..))+import qualified Data.List as List (length)+#if MIN_VERSION_base(4,7,0)+import Foreign.C.Types  (CSize(..), CInt(..))+#elif MIN_VERSION_base(4,4,0)+import Foreign.C.Types  (CSize(..), CInt(..), CLong(..))+#else+import Foreign.C.Types  (CSize, CInt, CLong)+#endif+import Foreign.Ptr+import Foreign.ForeignPtr (touchForeignPtr)+#if MIN_VERSION_base(4,5,0)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+#else+import Foreign.ForeignPtr (unsafeForeignPtrToPtr)+#endif++#if MIN_VERSION_base(4,5,0)+import qualified GHC.Exts+#endif+import GHC.Exts ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#)+                , State#, RealWorld+                , ByteArray#, MutableByteArray#+                , newByteArray#+#if MIN_VERSION_base(4,6,0)+                , newPinnedByteArray#+                , byteArrayContents#+                , unsafeCoerce#+#endif+#if MIN_VERSION_base(4,3,0)+                , sizeofByteArray#+#endif+                , indexWord8Array#, indexCharArray#+                , writeWord8Array#, writeCharArray#+                , unsafeFreezeByteArray# )+import GHC.IO+#if MIN_VERSION_base(4,6,0)+import GHC.ForeignPtr (ForeignPtr(ForeignPtr), ForeignPtrContents(PlainPtr))+#else+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+#endif+import GHC.ST         (ST(ST), runST)+import GHC.Word++import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..)+               , ($), error, (++)+               , Bool(..), (&&), otherwise+               , (+), (-), fromIntegral+               , return )+++-- | A compact representation of a 'Word8' vector.+--+-- It has a lower memory overhead than a 'ByteString' and and does not+-- contribute to heap fragmentation. It can be converted to or from a+-- 'ByteString' (at the cost of copying the string data). It supports very few+-- other operations.+--+-- It is suitable for use as an internal representation for code that needs+-- to keep many short strings in memory, but it /should not/ be used as an+-- interchange type. That is, it should not generally be used in public APIs.+-- The 'ByteString' type is usually more suitable for use in interfaces; it is+-- more flexible and it supports a wide range of operations.+--+data ShortByteString = SBS ByteArray#+#if !(MIN_VERSION_base(4,3,0))+                           Int  -- ^ Prior to ghc-7.0.x, 'ByteArray#'s reported+                                -- their length rounded up to the nearest word.+                                -- This means we have to store the true length+                                -- separately, wasting a word.+#define LEN(x) (x)+#else+#define _len   /* empty */+#define LEN(x) /* empty */+#endif+    deriving Typeable++-- The ByteArray# representation is always word sized and aligned but with a+-- known byte length. Our representation choice for ShortByteString is to leave+-- the 0--3 trailing bytes undefined. This means we can use word-sized writes,+-- but we have to be careful with reads, see equateBytes and compareBytes below.+++instance Eq ShortByteString where+    (==)    = equateBytes++instance Ord ShortByteString where+    compare = compareBytes++instance Monoid ShortByteString where+    mempty  = empty+    mappend = append+    mconcat = concat++instance NFData ShortByteString++instance Show ShortByteString where+    showsPrec p ps r = showsPrec p (unpackChars ps) r++instance Read ShortByteString where+    readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ]++instance IsString ShortByteString where+    fromString = packChars++instance Data ShortByteString where+  gfoldl f z txt = z packBytes `f` (unpackBytes txt)+  toConstr _     = error "Data.ByteString.Short.ShortByteString.toConstr"+  gunfold _ _    = error "Data.ByteString.Short.ShortByteString.gunfold"+#if MIN_VERSION_base(4,2,0)+  dataTypeOf _   = mkNoRepType "Data.ByteString.Short.ShortByteString"+#else+  dataTypeOf _   = mkNorepType "Data.ByteString.Short.ShortByteString"+#endif++------------------------------------------------------------------------+-- Simple operations++-- | /O(1)/. The empty 'ShortByteString'.+empty :: ShortByteString+empty = create 0 (\_ -> return ())++-- | /O(1)/ The length of a 'ShortByteString'.+length :: ShortByteString -> Int+#if MIN_VERSION_base(4,3,0)+length (SBS barr#) = I# (sizeofByteArray# barr#)+#else+length (SBS _ len) = len+#endif++-- | /O(1)/ Test whether a 'ShortByteString' is empty.+null :: ShortByteString -> Bool+null sbs = length sbs == 0++-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +index :: ShortByteString -> Int -> Word8+index sbs i+  | i >= 0 && i < length sbs = unsafeIndex sbs i+  | otherwise                = indexError sbs i++unsafeIndex :: ShortByteString -> Int -> Word8+unsafeIndex sbs = indexWord8Array (asBA sbs)++indexError :: ShortByteString -> Int -> a+indexError sbs i =+  error $ "Data.ByteString.Short.index: error in array index; " ++ show i+       ++ " not in range [0.." ++ show (length sbs) ++ ")"+++------------------------------------------------------------------------+-- Internal utils++asBA :: ShortByteString -> BA+asBA (SBS ba# _len) = BA# ba#++create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString+create len fill =+    runST (do+      mba <- newByteArray len+      fill mba+      BA# ba# <- unsafeFreezeByteArray mba+      return (SBS ba# LEN(len)))+{-# INLINE create #-}++------------------------------------------------------------------------+-- Conversion to and from ByteString++-- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'.+--+-- This makes a copy, so does not retain the input string.+--+toShort :: ByteString -> ShortByteString+toShort !bs = unsafeDupablePerformIO (toShortIO bs)++toShortIO :: ByteString -> IO ShortByteString+toShortIO (PS fptr off len) = do+    mba <- stToIO (newByteArray len)+    let ptr = unsafeForeignPtrToPtr fptr+    stToIO (copyAddrToByteArray (ptr `plusPtr` off) mba 0 len)+    touchForeignPtr fptr+    BA# ba# <- stToIO (unsafeFreezeByteArray mba)+    return (SBS ba# LEN(len))+++-- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'.+--+fromShort :: ShortByteString -> ByteString+fromShort !sbs = unsafeDupablePerformIO (fromShortIO sbs)++fromShortIO :: ShortByteString -> IO ByteString+fromShortIO sbs = do+#if MIN_VERSION_base(4,6,0)+    let len = length sbs+    mba@(MBA# mba#) <- stToIO (newPinnedByteArray len)+    stToIO (copyByteArray (asBA sbs) 0 mba 0 len)+    let fp = ForeignPtr (byteArrayContents# (unsafeCoerce# mba#))+                        (PlainPtr mba#)+    return (PS fp 0 len)+#else+    -- Before base 4.6 ForeignPtrContents is not exported from GHC.ForeignPtr+    -- so we cannot get direct access to the mbarr#+    let len = length sbs+    fptr <- mallocPlainForeignPtrBytes len+    let ptr = unsafeForeignPtrToPtr fptr+    stToIO (copyByteArrayToAddr (asBA sbs) 0 ptr len)+    touchForeignPtr fptr+    return (PS fptr 0 len)+#endif+++------------------------------------------------------------------------+-- Packing and unpacking from lists++-- | /O(n)/. Convert a list into a 'ShortByteString'+pack :: [Word8] -> ShortByteString+pack = packBytes++-- | /O(n)/. Convert a 'ShortByteString' into a list.+unpack :: ShortByteString -> [Word8]+unpack = unpackBytes++packChars :: [Char] -> ShortByteString+packChars cs = packLenChars (List.length cs) cs++packBytes :: [Word8] -> ShortByteString+packBytes cs = packLenBytes (List.length cs) cs++packLenChars :: Int -> [Char] -> ShortByteString+packLenChars len cs0 =+    create len (\mba -> go mba 0 cs0)+  where+    go :: MBA s -> Int -> [Char] -> ST s ()+    go !_   !_ []     = return ()+    go !mba !i (c:cs) = do+      writeCharArray mba i c+      go mba (i+1) cs++packLenBytes :: Int -> [Word8] -> ShortByteString+packLenBytes len ws0 =+    create len (\mba -> go mba 0 ws0)+  where+    go :: MBA s -> Int -> [Word8] -> ST s ()+    go !_   !_ []     = return ()+    go !mba !i (w:ws) = do+      writeWord8Array mba i w+      go mba (i+1) ws++-- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand+-- we would like to write a tight loop that just blats the list into memory, on+-- the other hand we want it to be unpacked lazily so we don't end up with a+-- massive list data structure in memory.+--+-- Our strategy is to combine both: we will unpack lazily in reasonable sized+-- chunks, where each chunk is unpacked strictly.+--+-- unpackChars does the lazy loop, while unpackAppendBytes and+-- unpackAppendChars do the chunks strictly.++unpackChars :: ShortByteString -> [Char]+unpackChars bs = unpackAppendCharsLazy bs []++unpackBytes :: ShortByteString -> [Word8]+unpackBytes bs = unpackAppendBytesLazy bs []++-- Why 100 bytes you ask? Because on a 64bit machine the list we allocate+-- takes just shy of 4k which seems like a reasonable amount.+-- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes)++unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char]+unpackAppendCharsLazy sbs cs0 =+    go 0 (length sbs) cs0+  where+    sz = 100++    go off len cs+      | len <= sz = unpackAppendCharsStrict sbs off len cs+      | otherwise = unpackAppendCharsStrict sbs off sz  remainder+                      where remainder = go (off+sz) (len-sz) cs++unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8]+unpackAppendBytesLazy sbs ws0 =+    go 0 (length sbs) ws0+  where+    sz = 100++    go off len ws+      | len <= sz = unpackAppendBytesStrict sbs off len ws+      | otherwise = unpackAppendBytesStrict sbs off sz  remainder+                      where remainder = go (off+sz) (len-sz) ws++-- For these unpack functions, since we're unpacking the whole list strictly we+-- build up the result list in an accumulator. This means we have to build up+-- the list starting at the end. So our traversal starts at the end of the+-- buffer and loops down until we hit the sentinal:++unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char]+unpackAppendCharsStrict !sbs off len cs =+    go (off-1) (off-1 + len) cs+  where+    go !sentinal !i !acc+      | i == sentinal = acc+      | otherwise     = let !c = indexCharArray (asBA sbs) i+                        in go sentinal (i-1) (c:acc)++unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8]+unpackAppendBytesStrict !sbs off len ws =+    go (off-1) (off-1 + len) ws+  where+    go !sentinal !i !acc+      | i == sentinal = acc+      | otherwise     = let !w = indexWord8Array (asBA sbs) i+                         in go sentinal (i-1) (w:acc)+++------------------------------------------------------------------------+-- Eq and Ord implementations++equateBytes :: ShortByteString -> ShortByteString -> Bool+equateBytes sbs1 sbs2 =+    let !len1 = length sbs1+        !len2 = length sbs2+     in len1 == len2+     && 0 == inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len1)++compareBytes :: ShortByteString -> ShortByteString -> Ordering+compareBytes sbs1 sbs2 =+    let !len1 = length sbs1+        !len2 = length sbs2+        !len  = min len1 len2+     in case inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len) of+          i | i    < 0    -> LT+            | i    > 0    -> GT+            | len2 > len1 -> LT+            | len2 < len1 -> GT+            | otherwise   -> EQ+++------------------------------------------------------------------------+-- Appending and concatenation++append :: ShortByteString -> ShortByteString -> ShortByteString+append src1 src2 =+  let !len1 = length src1+      !len2 = length src2+   in create (len1 + len2) $ \dst -> do+        copyByteArray (asBA src1) 0 dst 0    len1+        copyByteArray (asBA src2) 0 dst len1 len2++concat :: [ShortByteString] -> ShortByteString+concat sbss =+    create (totalLen 0 sbss) (\dst -> copy dst 0 sbss)+  where+    totalLen !acc []          = acc+    totalLen !acc (sbs: sbss) = totalLen (acc + length sbs) sbss++    copy :: MBA s -> Int -> [ShortByteString] -> ST s ()+    copy !_   !_   []                           = return ()+    copy !dst !off (src : sbss) = do+      let !len = length src+      copyByteArray (asBA src) 0 dst off len+      copy dst (off + len) sbss+++------------------------------------------------------------------------+-- Exported low level operations++copyToPtr :: ShortByteString  -- ^ source data+          -> Int              -- ^ offset into source+          -> Ptr a            -- ^ destination+          -> Int              -- ^ number of bytes to copy+          -> IO ()+copyToPtr src off dst len =+    stToIO $+      copyByteArrayToAddr (asBA src) off dst len++createFromPtr :: Ptr a   -- ^ source data+              -> Int     -- ^ number of bytes to copy+              -> IO ShortByteString+createFromPtr !ptr len =+    stToIO $ do+      mba <- newByteArray len+      copyAddrToByteArray ptr mba 0 len+      BA# ba# <- unsafeFreezeByteArray mba+      return (SBS ba# LEN(len))+++------------------------------------------------------------------------+-- Primop wrappers++data BA    = BA# ByteArray#+data MBA s = MBA# (MutableByteArray# s)++indexCharArray :: BA -> Int -> Char+indexCharArray (BA# ba#) (I# i#) = C# (indexCharArray# ba# i#)++indexWord8Array :: BA -> Int -> Word8+indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#)++newByteArray :: Int -> ST s (MBA s)+newByteArray (I# len#) =+    ST $ \s -> case newByteArray# len# s of+                 (# s, mba# #) -> (# s, MBA# mba# #)++#if MIN_VERSION_base(4,6,0)+newPinnedByteArray :: Int -> ST s (MBA s)+newPinnedByteArray (I# len#) =+    ST $ \s -> case newPinnedByteArray# len# s of+                 (# s, mba# #) -> (# s, MBA# mba# #)+#endif++unsafeFreezeByteArray :: MBA s -> ST s BA+unsafeFreezeByteArray (MBA# mba#) =+    ST $ \s -> case unsafeFreezeByteArray# mba# s of+                 (# s, ba# #) -> (# s, BA# ba# #)++writeCharArray :: MBA s -> Int -> Char -> ST s ()+writeCharArray (MBA# mba#) (I# i#) (C# c#) =+  ST $ \s -> case writeCharArray# mba# i# c# s of+               s -> (# s, () #)++writeWord8Array :: MBA s -> Int -> Word8 -> ST s ()+writeWord8Array (MBA# mba#) (I# i#) (W8# w#) =+  ST $ \s -> case writeWord8Array# mba# i# w# s of+               s -> (# s, () #)++copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()+copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) =+    ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of+                 s -> (# s, () #)++copyByteArrayToAddr :: BA -> Int -> Ptr a -> Int -> ST RealWorld ()+copyByteArrayToAddr (BA# src#) (I# src_off#) (Ptr dst#) (I# len#) =+    ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of+                 s -> (# s, () #)++copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s ()+copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) =+    ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of+                 s -> (# s, () #)+++------------------------------------------------------------------------+-- FFI imports++memcmp_ByteArray :: BA -> BA -> Int -> IO CInt+memcmp_ByteArray (BA# ba1#) (BA# ba2#) len =+  c_memcmp_ByteArray ba1# ba2# (fromIntegral len)++foreign import ccall unsafe "string.h memcmp"+  c_memcmp_ByteArray :: ByteArray# -> ByteArray# -> CSize -> IO CInt+++------------------------------------------------------------------------+-- Primop replacements++copyAddrToByteArray# :: Addr#+                     -> MutableByteArray# RealWorld -> Int#+                     -> Int#+                     -> State# RealWorld -> State# RealWorld++copyByteArrayToAddr# :: ByteArray# -> Int#+                     -> Addr#+                     -> Int#+                     -> State# RealWorld -> State# RealWorld++copyByteArray#       :: ByteArray# -> Int#+                     -> MutableByteArray# s -> Int#+                     -> Int#+                     -> State# s -> State# s++#if MIN_VERSION_base(4,7,0)++-- These exist as real primops in ghc-7.8, and for before that we use+-- FFI to C memcpy.+copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray#+copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr#++#else++copyAddrToByteArray# src dst dst_off len s =+  unIO_ (memcpy_AddrToByteArray dst (clong dst_off) src 0 (csize len)) s++copyAddrToByteArray0 :: Addr# -> MutableByteArray# s -> Int#+                     -> State# RealWorld -> State# RealWorld+copyAddrToByteArray0 src dst len s =+  unIO_ (memcpy_AddrToByteArray0 dst src (csize len)) s++{-# INLINE [0] copyAddrToByteArray# #-}+{-# RULES "copyAddrToByteArray# dst_off=0"+      forall src dst len s.+          copyAddrToByteArray# src dst 0# len s+        = copyAddrToByteArray0 src dst    len s  #-}++foreign import ccall unsafe "fpstring.h fps_memcpy_offsets"+  memcpy_AddrToByteArray :: MutableByteArray# s -> CLong -> Addr# -> CLong -> CSize -> IO ()++foreign import ccall unsafe "string.h memcpy"+  memcpy_AddrToByteArray0 :: MutableByteArray# s -> Addr# -> CSize -> IO ()+++copyByteArrayToAddr# src src_off dst len s =+  unIO_ (memcpy_ByteArrayToAddr dst 0 src (clong src_off) (csize len)) s++copyByteArrayToAddr0 :: ByteArray# -> Addr# -> Int#+                     -> State# RealWorld -> State# RealWorld+copyByteArrayToAddr0 src dst len s =+  unIO_ (memcpy_ByteArrayToAddr0 dst src (csize len)) s++{-# INLINE [0] copyByteArrayToAddr# #-}+{-# RULES "copyByteArrayToAddr# src_off=0"+      forall src dst len s.+          copyByteArrayToAddr# src 0# dst len s+        = copyByteArrayToAddr0 src    dst len s  #-}++foreign import ccall unsafe "fpstring.h fps_memcpy_offsets"+  memcpy_ByteArrayToAddr :: Addr# -> CLong -> ByteArray# -> CLong -> CSize -> IO ()++foreign import ccall unsafe "string.h memcpy"+  memcpy_ByteArrayToAddr0 :: Addr# -> ByteArray# -> CSize -> IO ()+++unIO_ :: IO () -> State# RealWorld -> State# RealWorld+unIO_ io s = case unIO io s of (# s, _ #) -> s++clong :: Int# -> CLong+clong i# = fromIntegral (I# i#)++csize :: Int# -> CSize+csize i# = fromIntegral (I# i#)+#endif++#if MIN_VERSION_base(4,5,0)+copyByteArray# = GHC.Exts.copyByteArray#+#else+copyByteArray# src src_off dst dst_off len s =+    unST_ (unsafeIOToST+      (memcpy_ByteArray dst (clong dst_off) src (clong src_off) (csize len))) s+  where+    unST (ST st) = st+    unST_ st s = case unST st s of (# s, _ #) -> s++foreign import ccall unsafe "fpstring.h fps_memcpy_offsets"+  memcpy_ByteArray :: MutableByteArray# s -> CLong+                   -> ByteArray# -> CLong -> CSize -> IO ()+#endif+