small-bytearray-builder 0.2.1.0 → 0.3.0.0

raw patch · 11 files changed

+932/−233 lines, 11 filesdep ~byteslicedep ~text-shortdep ~vectorPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: byteslice, text-short, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• bench/Cell.hs +32/−0
• bench/Main.hs +21/−0
• bench/SimpleCsv.hs +31/−0
• common/Word16Tree.hs +84/−0
• small-bytearray-builder.cabal +8/−2
• src/Data/ByteArray/Builder.hs +431/−151
• src/Data/ByteArray/Builder/Bounded.hs +67/−3
• src/Data/ByteArray/Builder/Unsafe.hs +56/−31
• src/Data/Bytes/Chunks.hs +76/−0
• test/Main.hs +108/−46

@@ -1,5 +1,23 @@ # Revision history for small-bytearray-builder +## 0.3.0.0 -- 2019-10-17++* Breaking change: Change the internal implementation of `Builder`. This+  now works a lot more like the builder from `bytestring`. It accumulates+  chunks and can do a zero-copy appends when working with a sufficiently+  large immutable chunk. This introduces a mild performance regression+  (around 10%), but it makes the libary more generally useful.+* Introduce `consLengthBE32` and `consLength64BE` for efficient serialization+  of wire protocols that require prefixing a payload with its length.+* Add `int{16,32,64}BE` and `int{16,32,64LE}` as conveniences.+* Add little-endian encoding functions for `Word16`, `Word32`, and `Word64`.+* Add big-endian and little-endian functions for copying a+  `PrimArray` of numbers (both signed and unsigned) into a builder.+* Add `flush`, `copy`, and `insert` for better control when+  converting byte sequences to builders.+* Add `shortByteString` to improve interoperability with the+  `bytestring` library. + ## 0.2.1.0 -- 2019-09-05  * Stop exporting data constructor in `Data.ByteArray.Builder`.

@@ -0,0 +1,32 @@+{-# language OverloadedLists #-}+{-# language OverloadedStrings #-}++module Cell+  ( Cell(..)+  , cells+  ) where++import Data.Word (Word32)+import Data.Text.Short (ShortText)+import Data.Primitive (SmallArray)++-- A cell in a CSV file+data Cell+  = CellString !ShortText+  | CellNumber !Word32++-- Some sample data to encode as a CSV+cells :: SmallArray (SmallArray Cell)+cells =+  [ [ CellString "Randy", CellString "Gutiérrez", CellNumber 41, CellNumber 343 ]+  , [ CellString "Édith", CellString "Piaf", CellNumber 63, CellNumber 453 ]+  , [ CellString "Martha", CellString "Washington", CellNumber 51, CellNumber 634 ]+  , [ CellString "Julius", CellString "Caesar", CellNumber 1, CellNumber 6922 ]+  , [ CellString "Robert", CellString "Redford", CellNumber 24, CellNumber 617 ]+  , [ CellString "Violet", CellString "Crawley", CellNumber 71, CellNumber 150 ]+  , [ CellString "Lázaro", CellString "Cárdenas", CellNumber 58, CellNumber 299 ]+  , [ CellString "Anastasia", CellString "San Martin", CellNumber 103, CellNumber 3214 ]+  , [ CellString "Mad", CellString "Max", CellNumber 37, CellNumber 918 ]+  , [ CellString "Sidonie-Gabrielle", CellString "Collette", CellNumber 25, CellNumber 904 ]+  ]+

@@ -1,12 +1,19 @@+{-# language LambdaCase #-}+{-# language OverloadedStrings #-}+ import Data.Primitive (ByteArray) import Data.Word (Word64) import Gauge (bgroup,bench,whnf) import Gauge.Main (defaultMain)  import qualified Arithmetic.Nat as Nat+import qualified Data.ByteArray.Builder as B import qualified Data.ByteArray.Builder.Bounded as U +import qualified Cell+import qualified SimpleCsv import qualified HexWord64+import qualified Word16Tree  main :: IO () main = defaultMain@@ -15,6 +22,20 @@       [ bench "library" (whnf encodeHexWord64s w64s)       , bench "loop" (whnf encodeHexWord64sLoop w64s)       ]+    ]+  , bgroup "unbounded"+    [ bench "csv-no-escape" $ whnf+        (\x -> B.run 4080 (SimpleCsv.encodeRows x))+        Cell.cells+    , bench "word-16-tree-small" $ whnf+        (\x -> B.run 4080 (Word16Tree.encode x))+        Word16Tree.exampleSmall+    , bench "word-16-tree-2000" $ whnf+        (\x -> B.run ((4096 * 16) - 16) (Word16Tree.encode x))+        Word16Tree.example2000+    , bench "word-16-tree-9000" $ whnf+        (\x -> B.run ((4096 * 64) - 16) (Word16Tree.encode x))+        Word16Tree.example9000     ]   ] 

@@ -0,0 +1,31 @@+{-# language LambdaCase #-}++-- A variant of CSV encoding that does not perform+-- any escaping or quoting. This is in its own module+-- to make it easy to analyze the GHC Core that it+-- gets compiled to.+module SimpleCsv+  ( encodeRows+  ) where++import Cell (Cell(..))+import Data.Primitive (SmallArray)++import qualified Data.Foldable as F+import qualified Data.ByteArray.Builder as B++encodeRows :: SmallArray (SmallArray Cell) -> B.Builder+encodeRows = F.foldr+  (\r x -> encodeSimpleCsvRow r (B.ascii '\n' <> x))+  mempty++encodeSimpleCsvRow :: SmallArray Cell -> B.Builder -> B.Builder+encodeSimpleCsvRow cs b = F.foldr+  (\c x -> encodeSimpleCsvCell c <> B.ascii ',' <> x)+  b+  cs++encodeSimpleCsvCell :: Cell -> B.Builder+encodeSimpleCsvCell = \case+  CellNumber n -> B.word32Dec n+  CellString t -> B.shortTextUtf8 t

@@ -0,0 +1,84 @@+{-# language BangPatterns #-}++module Word16Tree+  ( Word16Tree+  , encode+  , exampleSmall+  , example2000+  , example9000+  , expectedSmall+  ) where++import Data.ByteArray.Builder as B+import Data.Word (Word16)+import Data.Primitive (ByteArray)+import qualified Data.Bytes as Bytes++data Word16Tree+  = Branch !Word16Tree !Word16Tree+  | Leaf {-# UNPACK #-} !Word16++encode :: Word16Tree -> Builder+encode (Leaf w) = B.word16PaddedUpperHex w+encode (Branch a b) =+  B.ascii '('+  <>+  encode a+  <>+  B.ascii ','+  <>+  encode b+  <>+  B.ascii ')'++expectedSmall :: ByteArray+expectedSmall = Bytes.toByteArray $ Bytes.fromAsciiString+  "((AB59,(1F33,2E71)),((((FA9A,247B),890C),(0F13,((55BF,7CF1),389B))),1205))"+++exampleSmall :: Word16Tree+exampleSmall = Branch+  (Branch+    (Leaf 0xAB59)+    (Branch+      (Leaf 0x1F33)+      (Leaf 0x2E71)+    )+  )+  (Branch+    (Branch +      (Branch+        (Branch+          (Leaf 0xFA9A)+          (Leaf 0x247B)+        )+        (Leaf 0x890C)+      )+      (Branch+        (Leaf 0x0F13)+        (Branch+          (Branch+            (Leaf 0x55BF)+            (Leaf 0x7CF1)+          )+          (Leaf 0x389B)+        )+      )+    )+    (Leaf 0x1205)+  )++example2000 :: Word16Tree+{-# noinline example2000 #-}+example2000 = balanced 0 2000++example9000 :: Word16Tree+{-# noinline example9000 #-}+example9000 = balanced 0 9000++balanced :: Word16 -> Word16 -> Word16Tree+balanced !off !n+  | n == 0 = Leaf off+  | n == 1 = Leaf (off + 1)+  | otherwise = let x = div n 2 in+      Branch (balanced off x) (balanced (off + x) (n - x))

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: small-bytearray-builder-version: 0.2.1.0+version: 0.3.0.0 synopsis: Serialize to a small byte arrays description:   This is similar to the builder facilities provided by@@ -36,6 +36,7 @@  library   exposed-modules:+    Data.Bytes.Chunks     Data.ByteArray.Builder     Data.ByteArray.Builder.Unsafe     Data.ByteArray.Builder.Bounded@@ -45,7 +46,6 @@     , byteslice >=0.1 && <0.2     , primitive-offset >=0.2 && <0.3     , run-st >=0.1 && <0.2-    , vector >=0.12.0.3 && <0.13     , bytestring >=0.10.8.2 && <0.11     , text-short >=0.1.3 && <0.2     , natural-arithmetic >=0.1 && <0.2@@ -65,6 +65,7 @@   ghc-options: -O2 -Wall   other-modules:     HexWord64+    Word16Tree   build-depends:     , QuickCheck >=2.13.1 && <2.14     , base >=4.12.0.0 && <5@@ -87,9 +88,14 @@     , natural-arithmetic     , primitive     , small-bytearray-builder+    , text-short+    , byteslice   ghc-options: -Wall -O2   default-language: Haskell2010   hs-source-dirs: bench, common   main-is: Main.hs   other-modules:+    Cell     HexWord64+    SimpleCsv+    Word16Tree

@@ -1,4 +1,5 @@ {-# language BangPatterns #-}+{-# language DataKinds #-} {-# language DuplicateRecordFields #-} {-# language LambdaCase #-} {-# language MagicHash #-}@@ -9,19 +10,15 @@ module Data.ByteArray.Builder   ( -- * Bounded Primitives     Builder-  , construct   , fromBounded     -- * Evaluation   , run-  , pasteST-  , pasteIO-  , pasteGrowST-  , pasteGrowIO-  , pasteArrayST-  , pasteArrayIO     -- * Materialized Byte Sequences   , bytes-  , bytearray+  , copy+  , insert+  , byteArray+  , shortByteString   , shortTextUtf8   , shortTextJsonString   , cstring@@ -54,138 +51,99 @@   , ascii   , char     -- ** Machine-Readable+    -- *** One+  , word8+    -- **** Big Endian   , word64BE   , word32BE   , word16BE-  , word8+  , int64BE+  , int32BE+  , int16BE+    -- **** Little Endian+  , word64LE+  , word32LE+  , word16LE+  , int64LE+  , int32LE+  , int16LE+    -- *** Many+  , word8Array+    -- **** Big Endian+  , word16ArrayBE+  , word32ArrayBE+  , word64ArrayBE+  , int64ArrayBE+  , int32ArrayBE+  , int16ArrayBE+    -- **** Little Endian+  , word16ArrayLE+  , word32ArrayLE+  , word64ArrayLE+  , int64ArrayLE+  , int32ArrayLE+  , int16ArrayLE+    -- ** Prefixing with Length+  , consLength32BE+  , consLength64BE     -- * Encode Floating-Point Types     -- ** Human-Readable   , doubleDec+    -- * Control+  , flush   ) where  import Control.Monad.Primitive (primitive_)-import Control.Monad.ST (ST,stToIO)-import Control.Monad.ST.Run (runByteArrayST)+import Control.Monad.ST (ST,runST) import Data.ByteArray.Builder.Unsafe (Builder(Builder))+import Data.ByteArray.Builder.Unsafe (Commits(Initial,Mutable,Immutable)) import Data.ByteArray.Builder.Unsafe (stringUtf8,cstring) import Data.ByteString.Short.Internal (ShortByteString(SBS))-import Data.Bytes.Types (Bytes(Bytes),MutableBytes(MutableBytes))+import Data.Bytes.Types (Bytes(Bytes)) import Data.Char (ord) import Data.Int (Int64,Int32,Int16,Int8)-import Data.Primitive (ByteArray(..),MutableByteArray(..))-import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..))+import Data.Primitive (ByteArray(..),MutableByteArray(..),PrimArray(..)) import Data.Text.Short (ShortText) import Data.Word (Word64,Word32,Word16,Word8)-import GHC.Exts (Int(I#),Char(C#),Int#,State#,ByteArray#,RealWorld,(>=#),(/=#))+import GHC.Exts (Int(I#),Char(C#),Int#,State#,ByteArray#,(>=#))+import GHC.Exts (MutableByteArray#,(+#),(-#),(<#)) import GHC.ST (ST(ST))+import Data.Bytes.Chunks (Chunks(..))+import GHC.ByteOrder (ByteOrder(BigEndian,LittleEndian),targetByteOrder)  import qualified Arithmetic.Nat as Nat import qualified Arithmetic.Types as Arithmetic import qualified GHC.Exts as Exts import qualified Data.Text.Short as TS import qualified Data.Primitive as PM-import qualified Data.Vector as V import qualified Data.ByteArray.Builder.Bounded as Bounded import qualified Data.ByteArray.Builder.Bounded.Unsafe as UnsafeBounded --- | Run a builder. An accurate size hint is important for good performance.--- The size hint should be slightly larger than the actual size.+-- | Run a builder. run ::-     Int -- ^ Hint for upper bound on size+     Int -- ^ Size of initial chunk (use 4080 if uncertain)   -> Builder -- ^ Builder-  -> ByteArray-run hint b = runByteArrayST $ do-  let go !n = do-        arr <- PM.newByteArray n-        pasteST b (MutableBytes arr 0 n) >>= \case-          Nothing -> go (n + 64)-          Just len -> do-            shrinkMutableByteArray arr len-            PM.unsafeFreezeByteArray arr-  go (max hint 1)---- | Variant of 'pasteArrayST' that runs in 'IO'.-pasteArrayIO ::-     MutableBytes RealWorld -- ^ Buffer-  -> (a -> Builder) -- ^ Builder-  -> V.Vector a -- ^ Elements to serialize-  -> IO (V.Vector a, MutableBytes RealWorld) -- ^ Shifted vector, shifted buffer-pasteArrayIO !arr f !xs = stToIO (pasteArrayST arr f xs)---- | Fold over a vector, applying the builder to each element until--- the buffer cannot accomodate any more.-pasteArrayST ::-     MutableBytes s -- ^ Buffer-  -> (a -> Builder) -- ^ Builder-  -> V.Vector a -- ^ Elements to serialize-  -> ST s (V.Vector a, MutableBytes s) -- ^ Shifted vector, shifted buffer-pasteArrayST (MutableBytes arr off0 len0) f !xs0 = do-  let go !xs !ixBufA !lenBufA = if V.length xs > 0-        then do-          let a = V.unsafeHead xs-          pasteST (f a) (MutableBytes arr ixBufA lenBufA) >>= \case-            Nothing -> pure (xs,MutableBytes arr ixBufA lenBufA)-            Just ixBufB ->-              go (V.unsafeTail xs) ixBufB (lenBufA + (ixBufA - ixBufB))-        else pure (xs,MutableBytes arr ixBufA lenBufA)-  go xs0 off0 len0---- | Paste the builder into the byte array starting at offset zero.--- This repeatedly reallocates the byte array if it cannot accomodate--- the builder, replaying the builder each time.-pasteGrowST ::-     Int -- ^ How many bytes to grow by at a time-  -> Builder-  -> MutableByteArrayOffset s-     -- ^ Initial buffer, used linearly. Do not reuse this argument.-  -> ST s (MutableByteArrayOffset s)-     -- ^ Final buffer that accomodated the builder.-pasteGrowST !n b !(MutableByteArrayOffset arr0 off0) = do-  let go !arr !sz = pasteST b (MutableBytes arr off0 (sz - off0)) >>= \case-        Nothing -> do-          let szNext = sz + n-          arrNext <- PM.resizeMutableByteArray arr szNext-          go arrNext szNext-        Just ix -> pure (MutableByteArrayOffset{array=arr,offset=ix})-  go arr0 =<< PM.getSizeofMutableByteArray arr0---- | Variant of 'pasteGrowST' that runs in 'IO'.-pasteGrowIO ::-     Int -- ^ How many bytes to grow by at a time-  -> Builder-  -> MutableByteArrayOffset RealWorld-     -- ^ Initial buffer, used linearly. Do not reuse this argument.-  -> IO (MutableByteArrayOffset RealWorld)-     -- ^ Final buffer that accomodated the builder.-pasteGrowIO !n b !arr = stToIO (pasteGrowST n b arr)---- | Execute the builder, pasting its contents into a buffer.--- If the buffer is not large enough, this returns 'Nothing'.--- Otherwise, it returns the index in the buffer that follows--- the payload just written.-pasteST :: Builder -> MutableBytes s -> ST s (Maybe Int)-{-# inline pasteST #-}-pasteST (Builder f) (MutableBytes (MutableByteArray arr) (I# off) (I# len)) =-  ST $ \s0 -> case f arr off len s0 of-    (# s1, r #) -> if Exts.isTrue# (r /=# (-1#))-      then (# s1, Just (I# r) #)-      else (# s1, Nothing #)---- | Variant of 'pasteST' that runs in 'IO'.-pasteIO :: Builder -> MutableBytes RealWorld -> IO (Maybe Int)-{-# inline pasteIO #-}-pasteIO b m = stToIO (pasteST b m)+  -> Chunks+run hint@(I# hint# ) (Builder f) = runST $ do+  MutableByteArray buf0 <- PM.newByteArray hint+  cs <- ST $ \s0 -> case f buf0 0# hint# Initial s0 of+    (# s1, bufX, offX, _, csX #) ->+      (# s1, Mutable bufX offX csX #)+  commitsOntoChunks ChunksNil cs --- | Constructor for 'Builder' that works on a function with lifted--- arguments instead of unlifted ones. This is just as unsafe as the--- actual constructor.-construct :: (forall s. MutableBytes s -> ST s (Maybe Int)) -> Builder-construct f = Builder-  $ \arr off len s0 ->-    case unST (f (MutableBytes (MutableByteArray arr) (I# off) (I# len))) s0 of-      (# s1, m #) -> case m of-        Nothing -> (# s1, (-1#) #)-        Just (I# n) -> (# s1, n #)+-- Internal. This freezes all the mutable byte arrays in-place,+-- so be careful. It also reverses the chunks since everything+-- is backwards.+commitsOntoChunks :: Chunks -> Commits s -> ST s Chunks+commitsOntoChunks !xs Initial = pure xs+commitsOntoChunks !xs (Immutable arr off len cs) =+  commitsOntoChunks (ChunksCons (Bytes (ByteArray arr) (I# off) (I# len)) xs) cs+commitsOntoChunks !xs (Mutable buf len cs) = case len of+  0# -> commitsOntoChunks xs cs+  _ -> do+    shrinkMutableByteArray (MutableByteArray buf) (I# len)+    arr <- PM.unsafeFreezeByteArray (MutableByteArray buf)+    commitsOntoChunks (ChunksCons (Bytes arr 0 (I# len)) xs) cs  -- | Convert a bounded builder to an unbounded one. If the size -- is a constant, use @Arithmetic.Nat.constant@ as the first argument@@ -195,54 +153,249 @@   -> Bounded.Builder n   -> Builder {-# inline fromBounded #-}-fromBounded n (UnsafeBounded.Builder f) = Builder $ \arr off len s0 ->-  let !(I# req) = Nat.demote n in-  case len >=# req of-    1# -> f arr off s0-    _ -> (# s0, (-1#) #)+fromBounded n (UnsafeBounded.Builder f) = Builder $ \buf0 off0 len0 cs0 s0 ->+  let !(I# req) = Nat.demote n+      !(# s1, buf1, off1, len1, cs1 #) = case len0 >=# req of+        1# -> (# s0, buf0, off0, len0, cs0 #)+        _ -> let !(I# lenX) = max 4080 (I# req) in+          case Exts.newByteArray# lenX s0 of+            (# sX, bufX #) ->+              (# sX, bufX, 0#, lenX, Mutable buf0 off0 cs0 #)+   in case f buf1 off1 s1 of+        (# s2, off2 #) -> (# s2, buf1, off2, len1 -# (off2 -# off1), cs1 #) +-- This is a micro-optimization that uses an equality check instead+-- of an inequality check when the required number of bytes is one.+-- Use this instead of fromBounded (where possible) leads to marginally+-- better results in benchmarks.+fromBoundedOne ::+     Bounded.Builder 1+  -> Builder+{-# inline fromBoundedOne #-}+fromBoundedOne (UnsafeBounded.Builder f) = Builder $ \buf0 off0 len0 cs0 s0 ->+  let !(# s1, buf1, off1, len1, cs1 #) = case len0 of+        0# -> case Exts.newByteArray# 4080# s0 of+          (# sX, bufX #) ->+            (# sX, bufX, 0#, 4080#, Mutable buf0 off0 cs0 #)+        _ -> (# s0, buf0, off0, len0, cs0 #)+   in case f buf1 off1 s1 of+        (# s2, off2 #) -> (# s2, buf1, off2, len1 -# (off2 -# off1), cs1 #)+ -- | Create a builder from an unsliced byte sequence.-bytearray :: ByteArray -> Builder-bytearray a = bytes (Bytes a 0 (PM.sizeofByteArray a))+byteArray :: ByteArray -> Builder+byteArray a = bytes (Bytes a 0 (PM.sizeofByteArray a)) --- | Create a builder from a sliced byte sequence.+-- | Create a builder from a short bytestring.+shortByteString :: ShortByteString -> Builder+shortByteString (SBS x) = bytes (Bytes a 0 (PM.sizeofByteArray a))+  where a = ByteArray x++-- | Create a builder from a sliced byte sequence. The variants+-- 'copy' and 'insert' provide more control over whether or not+-- the byte sequence is copied or aliased. This function is preferred+-- when the user does not know the size of the byte sequence. bytes :: Bytes -> Builder-bytes (Bytes src soff slen) = construct $ \(MutableBytes arr off len) -> if len >= slen-  then do-    PM.copyByteArray arr off src soff slen-    pure (Just (off + slen))-  else pure Nothing+bytes (Bytes (ByteArray src# ) (I# soff# ) (I# slen# )) = Builder+  -- There are three cases to consider: (1) there is not enough+  -- space and (1a) the chunk is not small or (1b) the chunk is+  -- small; (2) There is enough space for a copy.+  (\buf0 off0 len0 cs0 s0 -> case len0 <# slen# of+    1# -> case slen# >=# 256# of+      1# -> case Exts.newByteArray# 0# s0 of+        (# s1, buf1 #) -> (# s1, buf1, 0#, 0#, Immutable src# soff# slen# (Mutable buf0 off0 cs0) #)+      _ -> case Exts.newByteArray# 4080# s0 of+        (# s1, buf1 #) -> case Exts.copyByteArray# src# soff# buf1 0# slen# s1 of+          s2 -> (# s2, buf1, slen#, 4080# -# slen#, Mutable buf0 off0 cs0 #)+    _ -> let !s1 = Exts.copyByteArray# src# soff# buf0 off0 slen# s0 in+      (# s1, buf0, off0 +# slen#, len0 -# slen#, cs0 #)+  ) +-- | Create a builder from a byte sequence. This always results in a+-- call to @memcpy@. This is beneficial when the byte sequence is+-- known to be small (less than 256 bytes).+copy :: Bytes -> Builder+copy (Bytes (ByteArray src# ) (I# soff# ) (I# slen# )) = Builder+  (\buf0 off0 len0 cs0 s0 -> case len0 <# slen# of+    1# -> case Exts.newByteArray# newSz s0 of+        (# s1, buf1 #) -> case Exts.copyByteArray# src# soff# buf1 0# slen# s1 of+          s2 -> (# s2, buf1, slen#, newSz -# slen#, Mutable buf0 off0 cs0 #)+    _ -> let !s1 = Exts.copyByteArray# src# soff# buf0 off0 slen# s0 in+      (# s1, buf0, off0 +# slen#, len0 -# slen#, cs0 #)+  )+  where+  !(I# newSz) = max (I# slen#) 4080++-- | Create a builder from a byte sequence. This never calls @memcpy@.+-- Instead, it pushes a chunk that references the argument byte sequence.+-- This wastes the remaining space in the active chunk, so it may adversely+-- affect performance if used carelessly. See 'flush' for a way to mitigate+-- this problem. This functions is most beneficial when the byte sequence+-- is known to be large (more than 8192 bytes).+insert :: Bytes -> Builder+insert (Bytes (ByteArray src# ) (I# soff# ) (I# slen# )) = Builder+  (\buf0 off0 _ cs0 s0 -> case Exts.newByteArray# 0# s0 of+    (# s1, buf1 #) ->+      (# s1, buf1, 0#, 0#, Immutable src# soff# slen# (Mutable buf0 off0 cs0) #)+  )++-- | Create a builder from a slice of an array of 'Word8'. There is the same+-- as 'bytes' but is provided as a convenience for users working with different+-- types.+word8Array :: PrimArray Word8 -> Int -> Int -> Builder+word8Array (PrimArray arr) off len = bytes (Bytes (ByteArray arr) off len)++int64ArrayLE :: PrimArray Int64 -> Int -> Int -> Builder+int64ArrayLE (PrimArray x) = word64ArrayLE (PrimArray x)++int64ArrayBE :: PrimArray Int64 -> Int -> Int -> Builder+int64ArrayBE (PrimArray x) = word64ArrayBE (PrimArray x)++int32ArrayLE :: PrimArray Int32 -> Int -> Int -> Builder+int32ArrayLE (PrimArray x) = word32ArrayLE (PrimArray x)++int32ArrayBE :: PrimArray Int32 -> Int -> Int -> Builder+int32ArrayBE (PrimArray x) = word32ArrayBE (PrimArray x)++int16ArrayLE :: PrimArray Int16 -> Int -> Int -> Builder+int16ArrayLE (PrimArray x) = word16ArrayLE (PrimArray x)++int16ArrayBE :: PrimArray Int16 -> Int -> Int -> Builder+int16ArrayBE (PrimArray x) = word16ArrayBE (PrimArray x)++word64ArrayLE :: PrimArray Word64 -> Int -> Int -> Builder+word64ArrayLE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  LittleEndian -> bytes (Bytes (ByteArray arr) (soff0 * 8) (slen0 * 8))+  BigEndian -> word64ArraySwap src soff0 slen0++word64ArrayBE :: PrimArray Word64 -> Int -> Int -> Builder+word64ArrayBE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  BigEndian -> bytes (Bytes (ByteArray arr) (soff0 * 8) (slen0 * 8))+  LittleEndian -> word64ArraySwap src soff0 slen0++word32ArrayLE :: PrimArray Word32 -> Int -> Int -> Builder+word32ArrayLE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  LittleEndian -> bytes (Bytes (ByteArray arr) (soff0 * 4) (slen0 * 4))+  BigEndian -> word32ArraySwap src soff0 slen0++word32ArrayBE :: PrimArray Word32 -> Int -> Int -> Builder+word32ArrayBE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  BigEndian -> bytes (Bytes (ByteArray arr) (soff0 * 4) (slen0 * 4))+  LittleEndian -> word32ArraySwap src soff0 slen0++word16ArrayLE :: PrimArray Word16 -> Int -> Int -> Builder+word16ArrayLE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  LittleEndian -> bytes (Bytes (ByteArray arr) (soff0 * 2) (slen0 * 2))+  BigEndian -> word16ArraySwap src soff0 slen0++word16ArrayBE :: PrimArray Word16 -> Int -> Int -> Builder+word16ArrayBE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  BigEndian -> bytes (Bytes (ByteArray arr) (soff0 * 2) (slen0 * 2))+  LittleEndian -> word16ArraySwap src soff0 slen0++word16ArraySwap :: PrimArray Word16 -> Int -> Int -> Builder+word16ArraySwap src soff0 slen0 =+  fromFunction (slen0 * 2) (go (soff0 * 2) ((soff0 + slen0) * 2))+  where+  go :: Int -> Int -> MutableByteArray s -> Int -> ST s Int+  go !soff !send !dst !doff = if soff < send+    then do+      let v0 = PM.indexPrimArray (asWord8s src) soff+          v1 = PM.indexPrimArray (asWord8s src) (soff + 1)+      PM.writeByteArray dst doff v1+      PM.writeByteArray dst (doff + 1) v0+      go (soff + 2) send dst (doff + 2)+    else pure doff++word32ArraySwap :: PrimArray Word32 -> Int -> Int -> Builder+word32ArraySwap src soff0 slen0 =+  fromFunction (slen0 * 4) (go (soff0 * 4) ((soff0 + slen0) * 4))+  where+  go :: Int -> Int -> MutableByteArray s -> Int -> ST s Int+  go !soff !send !dst !doff = if soff < send+    then do+      let v0 = PM.indexPrimArray (asWord8s src) soff+          v1 = PM.indexPrimArray (asWord8s src) (soff + 1)+          v2 = PM.indexPrimArray (asWord8s src) (soff + 2)+          v3 = PM.indexPrimArray (asWord8s src) (soff + 3)+      PM.writeByteArray dst doff v3+      PM.writeByteArray dst (doff + 1) v2+      PM.writeByteArray dst (doff + 2) v1+      PM.writeByteArray dst (doff + 3) v0+      go (soff + 4) send dst (doff + 4)+    else pure doff++word64ArraySwap :: PrimArray Word64 -> Int -> Int -> Builder+word64ArraySwap src soff0 slen0 =+  fromFunction (slen0 * 8) (go (soff0 * 8) ((soff0 + slen0) * 8))+  where+  go :: Int -> Int -> MutableByteArray s -> Int -> ST s Int+  go !soff !send !dst !doff = if soff < send+    then do+      let v0 = PM.indexPrimArray (asWord8s src) soff+          v1 = PM.indexPrimArray (asWord8s src) (soff + 1)+          v2 = PM.indexPrimArray (asWord8s src) (soff + 2)+          v3 = PM.indexPrimArray (asWord8s src) (soff + 3)+          v4 = PM.indexPrimArray (asWord8s src) (soff + 4)+          v5 = PM.indexPrimArray (asWord8s src) (soff + 5)+          v6 = PM.indexPrimArray (asWord8s src) (soff + 6)+          v7 = PM.indexPrimArray (asWord8s src) (soff + 7)+      PM.writeByteArray dst doff v7+      PM.writeByteArray dst (doff + 1) v6+      PM.writeByteArray dst (doff + 2) v5+      PM.writeByteArray dst (doff + 3) v4+      PM.writeByteArray dst (doff + 4) v3+      PM.writeByteArray dst (doff + 5) v2+      PM.writeByteArray dst (doff + 6) v1+      PM.writeByteArray dst (doff + 7) v0+      go (soff + 8) send dst (doff + 8)+    else pure doff++asWord8s :: PrimArray a -> PrimArray Word8+asWord8s (PrimArray x) = PrimArray x+ -- Internal function. Precondition, the referenced slice of the -- byte sequence is UTF-8 encoded text. slicedUtf8TextJson :: ByteArray# -> Int# -> Int# -> Builder {-# inline slicedUtf8TextJson #-}-slicedUtf8TextJson !src# !soff0# !slen0# = construct $ \(MutableBytes dst doff0 dlen0) ->-  let slen0 = I# slen0#-   in if dlen0 > (2 * slen0) + 2-        then do-          PM.writeByteArray dst doff0 (c2w '"')-          let go !soff !slen !doff = if slen > 0-                then case indexChar8Array (ByteArray src#) soff of-                  '\\' -> write2 dst doff '\\' '\\' *> go (soff + 1) (slen - 1) (doff + 2)-                  '\"' -> write2 dst doff '\\' '\"' *> go (soff + 1) (slen - 1) (doff + 2)-                  '\n' -> write2 dst doff '\\' 'n' *> go (soff + 1) (slen - 1) (doff + 2)-                  '\r' -> write2 dst doff '\\' 'r' *> go (soff + 1) (slen - 1) (doff + 2)-                  '\t' -> write2 dst doff '\\' 't' *> go (soff + 1) (slen - 1) (doff + 2)-                  c -> if c >= '\x20'-                    then PM.writeByteArray dst doff (c2w c) *> go (soff + 1) (slen - 1) (doff + 1)-                    else do-                      write2 dst doff '\\' 'u'-                      doff' <- UnsafeBounded.pasteST-                        (Bounded.word16PaddedUpperHex (fromIntegral (c2w c)))-                        dst (doff + 2)-                      go (soff + 1) (slen - 1) doff'-                else pure doff-          doffRes <- go (I# soff0#) (I# slen0#) (doff0 + 1)-          PM.writeByteArray dst doffRes (c2w '"')-          pure (Just (doffRes + 1))-        else pure Nothing+slicedUtf8TextJson !src# !soff0# !slen0# = fromFunction reqLen $ \dst doff0 -> do+  PM.writeByteArray dst doff0 (c2w '"')+  let go !soff !slen !doff = if slen > 0+        then case indexChar8Array (ByteArray src#) soff of+          '\\' -> write2 dst doff '\\' '\\' *> go (soff + 1) (slen - 1) (doff + 2)+          '\"' -> write2 dst doff '\\' '\"' *> go (soff + 1) (slen - 1) (doff + 2)+          '\n' -> write2 dst doff '\\' 'n' *> go (soff + 1) (slen - 1) (doff + 2)+          '\r' -> write2 dst doff '\\' 'r' *> go (soff + 1) (slen - 1) (doff + 2)+          '\t' -> write2 dst doff '\\' 't' *> go (soff + 1) (slen - 1) (doff + 2)+          c -> if c >= '\x20'+            then PM.writeByteArray dst doff (c2w c) *> go (soff + 1) (slen - 1) (doff + 1)+            else do+              write2 dst doff '\\' 'u'+              doff' <- UnsafeBounded.pasteST+                (Bounded.word16PaddedUpperHex (fromIntegral (c2w c)))+                dst (doff + 2)+              go (soff + 1) (slen - 1) doff'+        else pure doff+  doffRes <- go (I# soff0#) (I# slen0#) (doff0 + 1)+  PM.writeByteArray dst doffRes (c2w '"')+  pure (doffRes + 1)+  where+  slen0 = I# slen0#+  reqLen = (2 * slen0) + 2 +-- | Constructor for 'Builder' that works on a function with lifted+-- arguments instead of unlifted ones. This is just as unsafe as the+-- actual constructor.+fromFunction :: Int -> (forall s. MutableByteArray s -> Int -> ST s Int) -> Builder+fromFunction (I# req) f = Builder $ \buf0 off0 len0 cs0 s0 ->+  let !(# s1, buf1, off1, len1, cs1 #) = case len0 >=# req of+        1# -> (# s0, buf0, off0, len0, cs0 #)+        _ -> let !(I# lenX) = max 4080 (I# req) in+          case Exts.newByteArray# lenX s0 of+            (# sX, bufX #) ->+              (# sX, bufX, 0#, lenX, Mutable buf0 off0 cs0 #)+   in case unST (f (MutableByteArray buf1) (I# off1)) s1 of+        (# s2, I# off2 #) -> (# s2, buf1, off2, len1 -# (off2 -# off1), cs1 #)+ -- Internal. Write two characters in the ASCII plane to a byte array. write2 :: MutableByteArray s -> Int -> Char -> Char -> ST s () write2 marr ix a b = do@@ -399,7 +552,7 @@ -- | Encode an ASCII char. -- Precondition: Input must be an ASCII character. This is not checked. ascii :: Char -> Builder-ascii c = fromBounded Nat.constant (Bounded.char c)+ascii c = fromBoundedOne (Bounded.ascii c)  -- | Encode an UTF8 char. This only uses as much space as is required. char :: Char -> Builder@@ -413,6 +566,51 @@   primitive_ (Exts.shrinkMutableByteArray# arr sz)  -- | Requires exactly 8 bytes. Dump the octets of a 64-bit+-- signed integer in a little-endian fashion.+int64LE :: Int64 -> Builder+int64LE w = fromBounded Nat.constant (Bounded.int64LE w)++-- | Requires exactly 4 bytes. Dump the octets of a 32-bit+-- signed integer in a little-endian fashion.+int32LE :: Int32 -> Builder+int32LE w = fromBounded Nat.constant (Bounded.int32LE w)++-- | Requires exactly 2 bytes. Dump the octets of a 16-bit+-- signed integer in a little-endian fashion.+int16LE :: Int16 -> Builder+int16LE w = fromBounded Nat.constant (Bounded.int16LE w)++-- | Requires exactly 8 bytes. Dump the octets of a 64-bit+-- signed integer in a big-endian fashion.+int64BE :: Int64 -> Builder+int64BE w = fromBounded Nat.constant (Bounded.int64BE w)++-- | Requires exactly 4 bytes. Dump the octets of a 32-bit+-- signed integer in a big-endian fashion.+int32BE :: Int32 -> Builder+int32BE w = fromBounded Nat.constant (Bounded.int32BE w)++-- | Requires exactly 2 bytes. Dump the octets of a 16-bit+-- signed integer in a big-endian fashion.+int16BE :: Int16 -> Builder+int16BE w = fromBounded Nat.constant (Bounded.int16BE w)++-- | Requires exactly 8 bytes. Dump the octets of a 64-bit+-- word in a little-endian fashion.+word64LE :: Word64 -> Builder+word64LE w = fromBounded Nat.constant (Bounded.word64LE w)++-- | Requires exactly 4 bytes. Dump the octets of a 32-bit+-- word in a little-endian fashion.+word32LE :: Word32 -> Builder+word32LE w = fromBounded Nat.constant (Bounded.word32LE w)++-- | Requires exactly 2 bytes. Dump the octets of a 16-bit+-- word in a little-endian fashion.+word16LE :: Word16 -> Builder+word16LE w = fromBounded Nat.constant (Bounded.word16LE w)++-- | Requires exactly 8 bytes. Dump the octets of a 64-bit -- word in a big-endian fashion. word64BE :: Word64 -> Builder word64BE w = fromBounded Nat.constant (Bounded.word64BE w)@@ -427,8 +625,90 @@ word16BE :: Word16 -> Builder word16BE w = fromBounded Nat.constant (Bounded.word16BE w) +-- | Requires exactly 1 byte. word8 :: Word8 -> Builder-word8 w = fromBounded Nat.constant (Bounded.word8 w)+word8 w = fromBoundedOne (Bounded.word8 w)++-- | Prefix a builder with its size in bytes. This size is+-- presented as a big-endian 32-bit word. The need to prefix+-- a builder with its length shows up a numbers of wire protocols+-- including those of PostgreSQL and Apache Kafka. Note the+-- equivalence:+-- +-- > forall (n :: Int) (x :: Builder).+-- >   let sz = sizeofByteArray (run n (consLength32BE x))+-- >   consLength32BE x === word32BE (fromIntegral sz) <> x+--+-- However, using 'consLength32BE' is much more efficient here+-- since it only materializes the 'ByteArray' once.+consLength32BE :: Builder -> Builder+consLength32BE (Builder f) = Builder $ \buf0 off0 len0 cs0 s0 ->+  let !(# s1, buf1, off1, len1, cs1 #) = case len0 >=# 4# of+        1# -> (# s0, buf0, off0, len0, cs0 #)+        _ -> case Exts.newByteArray# 4080# s0 of+          (# sX, bufX #) ->+            (# sX, bufX, 0#, 4080#, Mutable buf0 off0 cs0 #)+   in case f buf1 (off1 +# 4# ) (len1 -# 4# ) cs1 s1 of+        (# s2, buf2, off2, len2, cs2 #) ->+          let !dist = case Exts.sameMutableByteArray# buf1 buf2 of+                1# -> off2 -# off1+                _ -> commitDistance buf1 off2 cs2 -# off1+              ST g = UnsafeBounded.pasteST+                (Bounded.word32BE (fromIntegral (I# (dist -# 4# ))))+                (MutableByteArray buf1)+                (I# off1)+           in case g s2 of+                (# s3, _ #) -> (# s3, buf2, off2, len2, cs2 #)+++-- | Prefix a builder with its size in bytes. This size is+-- presented as a big-endian 64-bit word. See 'consLength32BE'.+consLength64BE :: Builder -> Builder+consLength64BE (Builder f) = Builder $ \buf0 off0 len0 cs0 s0 ->+  let !(# s1, buf1, off1, len1, cs1 #) = case len0 >=# 8# of+        1# -> (# s0, buf0, off0, len0, cs0 #)+        _ -> case Exts.newByteArray# 4080# s0 of+          (# sX, bufX #) ->+            (# sX, bufX, 0#, 4080#, Mutable buf0 off0 cs0 #)+   in case f buf1 (off1 +# 8# ) (len1 -# 8# ) cs1 s1 of+        (# s2, buf2, off2, len2, cs2 #) ->+          let !dist = case Exts.sameMutableByteArray# buf1 buf2 of+                1# -> off2 -# off1+                _ -> commitDistance buf1 off2 cs2 -# off1+              ST g = UnsafeBounded.pasteST+                (Bounded.word64BE (fromIntegral (I# (dist -# 8# ))))+                (MutableByteArray buf1)+                (I# off1)+           in case g s2 of+                (# s3, _ #) -> (# s3, buf2, off2, len2, cs2 #)++commitDistance :: MutableByteArray# s -> Int# -> Commits s -> Int#+commitDistance _ !_ Initial = error "chunkDistance: chunk not found"+commitDistance target !n (Immutable _ _ len cs) =+  commitDistance target (n +# len) cs+commitDistance target !n (Mutable buf len cs) =+  case Exts.sameMutableByteArray# target buf of+    1# -> n +# len+    _ -> commitDistance target (n +# len) cs++-- | Push the buffer currently being filled onto the chunk list,+-- allocating a new active buffer of the requested size. This is+-- helpful when a small builder is sandwhiched between two large+-- zero-copy builders:+--+-- > insert bigA <> flush 1 <> word8 0x42 <> insert bigB+--+-- Without @flush 1@, @word8 0x42@ would see the zero-byte active+-- buffer that 'insert' returned, decide that it needed more space,+-- and allocate a 4080-byte buffer to which only a single byte+-- would be written.+flush :: Int -> Builder+flush !reqSz = Builder $ \buf0 off0 _ cs0 s0 ->+  case Exts.newByteArray# sz# s0 of+    (# sX, bufX #) ->+      (# sX, bufX, 0#, sz#, Mutable buf0 off0 cs0 #)+  where+  !(I# sz# ) = max reqSz 0  -- ShortText is already UTF-8 encoded. This is a no-op. shortTextToByteArray :: ShortText -> ByteArray

@@ -52,10 +52,22 @@   , ascii   , char     -- ** Machine-Readable+    -- *** One+  , word8+    -- **** Big Endian   , word64BE   , word32BE   , word16BE-  , word8+  , int64BE+  , int32BE+  , int16BE+    -- **** Little Endian+  , word64LE+  , word32LE+  , word16LE+  , int64LE+  , int32LE+  , int16LE     -- * Encode Floating-Point Types   , doubleDec   ) where@@ -507,10 +519,12 @@   where   w = W# w# --- | Encode an ASCII char.+-- | Encode an ASCII character. -- Precondition: Input must be an ASCII character. This is not checked. ascii :: Char -> Builder 1-ascii c = word8 (fromIntegral @Int @Word8 (ord c))+ascii (C# c) = Unsafe.construct $ \(MutableByteArray arr) (I# off) -> do+  primitive_ (writeCharArray# arr off c)+  pure (I# (off +# 1# ))  -- | Encode a character as UTF-8. This only uses as much space as is required. char :: Char -> Builder 4@@ -577,7 +591,39 @@     byteFourFour :: Word -> Word     byteFourFour w = (0b00111111 .&. w) .|. 0b10000000 +int64BE :: Int64 -> Builder 8+int64BE (I64# i) = word64BE (W64# (int2Word# i))++int32BE :: Int32 -> Builder 4+int32BE (I32# i) = word32BE (W32# (int2Word# i))++int16BE :: Int16 -> Builder 2+int16BE (I16# i) = word16BE (W16# (int2Word# i))++int64LE :: Int64 -> Builder 8+int64LE (I64# i) = word64LE (W64# (int2Word# i))++int32LE :: Int32 -> Builder 4+int32LE (I32# i) = word32LE (W32# (int2Word# i))++int16LE :: Int16 -> Builder 2+int16LE (I16# i) = word16LE (W16# (int2Word# i))+ -- | Requires exactly 8 bytes. Dump the octets of a 64-bit+-- word in a little-endian fashion.+word64LE :: Word64 -> Builder 8+word64LE w = Unsafe.construct $ \arr off -> do+  writeByteArray arr (off + 7) (fromIntegral @Word64 @Word8 (unsafeShiftR w 56))+  writeByteArray arr (off + 6) (fromIntegral @Word64 @Word8 (unsafeShiftR w 48))+  writeByteArray arr (off + 5) (fromIntegral @Word64 @Word8 (unsafeShiftR w 40))+  writeByteArray arr (off + 4) (fromIntegral @Word64 @Word8 (unsafeShiftR w 32))+  writeByteArray arr (off + 3) (fromIntegral @Word64 @Word8 (unsafeShiftR w 24))+  writeByteArray arr (off + 2) (fromIntegral @Word64 @Word8 (unsafeShiftR w 16))+  writeByteArray arr (off + 1) (fromIntegral @Word64 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off    ) (fromIntegral @Word64 @Word8 w)+  pure (off + 8)++-- | Requires exactly 8 bytes. Dump the octets of a 64-bit -- word in a big-endian fashion. word64BE :: Word64 -> Builder 8 word64BE w = Unsafe.construct $ \arr off -> do@@ -592,6 +638,16 @@   pure (off + 8)  -- | Requires exactly 4 bytes. Dump the octets of a 32-bit+-- word in a little-endian fashion.+word32LE :: Word32 -> Builder 4+word32LE w = Unsafe.construct $ \arr off -> do+  writeByteArray arr (off + 3) (fromIntegral @Word32 @Word8 (unsafeShiftR w 24))+  writeByteArray arr (off + 2) (fromIntegral @Word32 @Word8 (unsafeShiftR w 16))+  writeByteArray arr (off + 1) (fromIntegral @Word32 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off    ) (fromIntegral @Word32 @Word8 w)+  pure (off + 4)++-- | Requires exactly 4 bytes. Dump the octets of a 32-bit -- word in a big-endian fashion. word32BE :: Word32 -> Builder 4 word32BE w = Unsafe.construct $ \arr off -> do@@ -600,6 +656,14 @@   writeByteArray arr (off + 2) (fromIntegral @Word32 @Word8 (unsafeShiftR w 8))   writeByteArray arr (off + 3) (fromIntegral @Word32 @Word8 w)   pure (off + 4)++-- | Requires exactly 2 bytes. Dump the octets of a 16-bit+-- word in a little-endian fashion.+word16LE :: Word16 -> Builder 2+word16LE w = Unsafe.construct $ \arr off -> do+  writeByteArray arr (off + 1) (fromIntegral @Word16 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off    ) (fromIntegral @Word16 @Word8 w)+  pure (off + 2)  -- | Requires exactly 2 bytes. Dump the octets of a 16-bit -- word in a big-endian fashion.

@@ -9,6 +9,7 @@ module Data.ByteArray.Builder.Unsafe   ( -- * Types     Builder(..)+  , Commits(..)     -- * Safe Functions     -- | These functions are actually completely safe, but they are defined     -- here because they are used by typeclass instances. Import them from@@ -17,10 +18,10 @@   , cstring   ) where -import Data.Primitive (MutableByteArray(MutableByteArray))+import Data.Primitive (MutableByteArray(MutableByteArray),ByteArray) import Foreign.C.String (CString)-import GHC.Exts ((-#),(+#),(/=#),(>#))-import GHC.Exts (Addr#,Int(I#),Ptr(Ptr))+import GHC.Exts ((-#),(+#),(>#))+import GHC.Exts (Addr#,ByteArray#,MutableByteArray#,Int(I#),Ptr(Ptr)) import GHC.Exts (IsString,Int#,State#,MutableByteArray#) import GHC.ST (ST(ST)) import GHC.Base (unpackCString#,unpackCStringUtf8#)@@ -32,10 +33,14 @@ -- | An unmaterialized sequence of bytes that may be pasted -- into a mutable byte array. newtype Builder-  = Builder (forall s. MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #))-    -- ^ This function takes a buffer, an offset, and a number of remaining bytes.-    --   It returns the new offset (should be greater than the old offset), or if-    --   there was not enough space left in buffer, it returns -1.+  = Builder (forall s.+      MutableByteArray# s ->   -- buffer we are currently writing to+      Int# ->   -- offset into the current buffer+      Int# ->   -- number of bytes remaining in the current buffer+      Commits s ->   -- buffers and immutable byte slices that we have already committed+      State# s ->+      (# State# s, MutableByteArray# s, Int#, Int#, Commits s #) -- all the same things+    )  instance IsString Builder where   {-# inline fromString #-}@@ -43,53 +48,73 @@  instance Semigroup Builder where   {-# inline (<>) #-}-  Builder f <> Builder g = Builder $ \arr off0 len0 s0 -> case f arr off0 len0 s0 of-    (# s1, r #) -> case r /=# (-1#) of-      1# -> g arr r (len0 +# (off0 -# r)) s1-      _ -> (# s1, (-1#) #)+  Builder f <> Builder g = Builder $ \buf0 off0 len0 cs0 s0 -> case f buf0 off0 len0 cs0 s0 of+    (# s1, buf1, off1, len1, cs1 #) -> g buf1 off1 len1 cs1 s1  instance Monoid Builder where   {-# inline mempty #-}-  mempty = Builder $ \_ off0 _ s0 -> (# s0, off0 #)+  mempty = Builder $ \buf0 off0 len0 cs0 s0 -> (# s0, buf0, off0, len0, cs0 #) +data Commits s+  = Mutable+      (MutableByteArray# s)+      -- ^ Mutable buffer, start index implicitly zero+      Int# -- ^ Length (may be smaller than actual length)+      !(Commits s)+  | Immutable+      ByteArray# -- ^ Immutable chunk+      Int# -- ^ Offset into chunk, not necessarily zero+      Int# -- ^ Length (may be smaller than actual length)+      !(Commits s)+  | Initial+ -- | Create a builder from a cons-list of 'Char'. These -- are be UTF-8 encoded. stringUtf8 :: String -> Builder {-# inline stringUtf8 #-}-stringUtf8 cs = Builder (\arr off0 len0 s0 -> goString cs arr off0 len0 s0)+stringUtf8 cs = Builder (goString cs)  -- | Create a builder from a @NUL@-terminated 'CString'. This ignores any -- textual encoding, copying bytes until @NUL@ is reached. cstring :: CString -> Builder {-# inline cstring #-}-cstring (Ptr cs) = Builder (\arr off0 len0 s0 -> goCString cs arr off0 len0 s0)+cstring (Ptr cs) = Builder (goCString cs) -goString :: String -> MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+goString :: String+  -> MutableByteArray# s -> Int# -> Int# -> Commits s+  -> State# s -> (# State# s, MutableByteArray# s, Int#, Int#, Commits s #) {-# noinline goString #-}-goString [] _ off0 _ s0 = (# s0, off0 #)-goString (c : cs) buf off0 len0 s0 = case len0 ># 3# of-  1# -> case unST (UnsafeBounded.pasteST (Bounded.char c) (MutableByteArray buf) (I# off0)) s0 of-    (# s1, I# off1 #) -> goString cs buf off1 (len0 -# (off1 -# off0)) s1-  _ -> (# s0, (-1#) #)+goString [] buf0 off0 len0 cs0 s0 = (# s0, buf0, off0, len0, cs0 #)+goString (c : cs) buf0 off0 len0 cs0 s0 = case len0 ># 3# of+  1# -> case unST (UnsafeBounded.pasteST (Bounded.char c) (MutableByteArray buf0) (I# off0)) s0 of+    (# s1, I# off1 #) -> goString cs buf0 off1 (len0 -# (off1 -# off0)) cs0 s1+  _ -> case Exts.newByteArray# 4080# s0 of+    (# s1, buf1 #) -> case unST (UnsafeBounded.pasteST (Bounded.char c) (MutableByteArray buf1) 0) s1 of+      (# s2, I# off1 #) -> goString cs buf1 off1 (4080# -# off1) (Mutable buf0 off0 cs0) s2  -- We have to have a rule for both unpackCString# and unpackCStringUtf8# -- since GHC uses a different function based on whether or not non-ASCII -- codepoints are used in the string. {-# RULES-"Builder stringUtf8/cstring" forall s a b c d.-  goString (unpackCString# s) a b c d = goCString s a b c d-"Builder stringUtf8/cstring-utf8" forall s a b c d.-  goString (unpackCStringUtf8# s) a b c d = goCString s a b c d+"Builder stringUtf8/cstring" forall s a b c d e.+  goString (unpackCString# s) a b c d e = goCString s a b c d e+"Builder stringUtf8/cstring-utf8" forall s a b c d e.+  goString (unpackCStringUtf8# s) a b c d e = goCString s a b c d e #-} -goCString :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)-goCString addr buf off0 len0 s0 = case Exts.indexWord8OffAddr# addr 0# of-  0## -> (# s0, off0 #)+goCString :: Addr# -> MutableByteArray# s -> Int# -> Int# -> Commits s+  -> State# s -> (# State# s, MutableByteArray# s, Int#, Int#, Commits s #)+goCString addr buf0 off0 len0 cs0 s0 = case Exts.indexWord8OffAddr# addr 0# of+  0## -> (# s0, buf0, off0, len0, cs0 #)   w -> case len0 of-    0# -> (# s0, (-1#) #)-    _ -> case Exts.writeWord8Array# buf off0 w s0 of-      s1 -> goCString (Exts.plusAddr# addr 1# ) buf (off0 +# 1# ) (len0 -# 1# ) s1+    0# -> case Exts.newByteArray# 4080# s0 of+      (# s1, buf1 #) -> case Exts.writeWord8Array# buf1 0# w s1 of+        s2 -> goCString+          (Exts.plusAddr# addr 1# ) buf1 1# (4080# -# 1# )+          (Mutable buf0 off0 cs0)+          s2+    _ -> case Exts.writeWord8Array# buf0 off0 w s0 of+      s1 -> goCString (Exts.plusAddr# addr 1# ) buf0 (off0 +# 1# ) (len0 -# 1# ) cs0 s1  unST :: ST s a -> State# s -> (# State# s, a #) unST (ST f) = f-

@@ -0,0 +1,76 @@+{-# language BangPatterns #-}+{-# language DerivingStrategies #-}+{-# language TypeFamilies #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}+{-# language NamedFieldPuns #-}++module Data.Bytes.Chunks+  ( Chunks(..)+  , concat+  ) where++import Prelude hiding (length,concat)++import GHC.ST (ST(..))+import Data.Bytes.Types (Bytes(..))+import Data.Primitive (ByteArray(..),MutableByteArray(..))+import GHC.Exts (ByteArray#,MutableByteArray#)+import GHC.Exts (IsList,Int#,State#,Int(I#),(+#),(-#))+import Control.Monad.ST.Run (runByteArrayST)++import qualified GHC.Exts as Exts+import qualified Data.Primitive as PM++data Chunks+  = ChunksCons {-# UNPACK #-} !Bytes !Chunks+  | ChunksNil++concat :: Chunks -> ByteArray+concat x = ByteArray (concat# x)++concat# :: Chunks -> ByteArray#+{-# noinline concat# #-}+concat# ChunksNil = case mempty of {ByteArray x -> x}+concat# (ChunksCons (Bytes{array=c,offset=coff,length=szc}) cs) = case cs of+  ChunksNil -> case c of {ByteArray x -> x}+  ChunksCons (Bytes{array=d,offset=doff,length=szd}) ds ->+    unBa $ runByteArrayST $ do+      let szboth = szc + szd+          len = chunksLengthGo szboth ds+      dst <- PM.newByteArray len+      PM.copyByteArray dst 0 c coff szc+      PM.copyByteArray dst szc d doff szd+      _ <- copy dst szboth ds+      PM.unsafeFreezeByteArray dst++chunksLengthGo :: Int -> Chunks -> Int+chunksLengthGo !n ChunksNil = n+chunksLengthGo !n (ChunksCons (Bytes{length}) cs) =+  chunksLengthGo (n + length) cs++-- | Copy the contents of the chunks into a mutable array.+-- Precondition: The destination must have enough space to+-- house the contents. This is not checked.+copy ::+     MutableByteArray s -- ^ Destination+  -> Int -- ^ Destination offset+  -> Chunks -- ^ Source+  -> ST s Int -- ^ Returns the next index into the destination after the payload+{-# inline copy #-}+copy (MutableByteArray dst) (I# off) cs = ST+  (\s0 -> case copy# dst off cs s0 of+    (# s1, nextOff #) -> (# s1, I# nextOff #)+  )++copy# :: MutableByteArray# s -> Int# -> Chunks -> State# s -> (# State# s, Int# #)+copy# _ off ChunksNil s0 = (# s0, off #)+copy# marr off (ChunksCons (Bytes{array,offset,length}) cs) s0 =+  case Exts.copyByteArray# (unBa array) (unI offset) marr off (unI length) s0 of+    s1 -> copy# marr (off +# unI length) cs s1++unI :: Int -> Int#+unI (I# i) = i++unBa :: ByteArray -> ByteArray#+unBa (ByteArray x) = x

@@ -4,10 +4,10 @@ {-# language OverloadedStrings #-}  import Control.Monad.ST (runST)-import Data.Bytes.Types (MutableBytes(..)) import Data.ByteArray.Builder+import Data.Primitive (PrimArray) import Data.Word-import Data.Char (ord)+import Data.Char (ord,chr) import Data.Primitive (ByteArray) import Test.Tasty (defaultMain,testGroup,TestTree) import Test.QuickCheck ((===))@@ -18,16 +18,17 @@ import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Data.Bytes.Chunks as Chunks import qualified Data.List as L import qualified Data.Primitive as PM import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Data.Vector as V import qualified GHC.Exts as Exts import qualified Test.Tasty.HUnit as THU import qualified Test.Tasty.QuickCheck as TQC  import qualified HexWord64+import qualified Word16Tree  main :: IO () main = defaultMain tests@@ -36,68 +37,137 @@ tests = testGroup "Tests"   [ testGroup "live"     [ TQC.testProperty "word64Dec" $ \w ->-        run 1 (word64Dec w) === pack (show w)+        runConcat 1 (word64Dec w) === pack (show w)     , TQC.testProperty "word64Dec-x3" $ \x y z ->-        run 1 (word64Dec x <> word64Dec y <> word64Dec z)+        runConcat 1 (word64Dec x <> word64Dec y <> word64Dec z)         ===         pack (show x ++ show y ++ show z)     , TQC.testProperty "int64Dec-x3" $ \x y z ->-        run 1 (int64Dec x <> int64Dec y <> int64Dec z)+        runConcat 1 (int64Dec x <> int64Dec y <> int64Dec z)         ===         pack (show x ++ show y ++ show z)     , TQC.testProperty "word64BE-x3" $ \x y z ->-        run 1 (word64BE x <> word64BE y <> word64BE z)+        runConcat 1 (word64BE x <> word64BE y <> word64BE z)         ===         pack (LB.unpack (BB.toLazyByteString (BB.word64BE x <> BB.word64BE y <> BB.word64BE z)))     , TQC.testProperty "word64PaddedUpperHex" $ \w ->-        run 1 (word64PaddedUpperHex w)+        runConcat 1 (word64PaddedUpperHex w)         ===         pack (showWord64PaddedUpperHex w)     , TQC.testProperty "word8Dec" $ \w ->-        run 1 (word8Dec w)+        runConcat 1 (word8Dec w)         ===         pack (show w)-    , TQC.testProperty "pasteArrayST" $ \(xs :: [Word64]) ->-        (runArray word64Dec (V.fromList xs))+    , TQC.testProperty "consLength32BE" $ \w ->+        runConcat 1 (consLength32BE (word8Dec w))         ===-        pack (foldMap show xs)+        pack ('\x00' : '\x00' : '\x00' : chr (L.length (show w)) : show w)+    , TQC.testProperty "consLength64BE-uni" $ \w ->+        pack+          ( '\x00' : '\x00' : '\x00' : '\x00'+          : '\x00' : '\x00' : '\x00' : chr (L.length (show w))+          : show w+          )+        ===+        runConcat 1 (consLength64BE (word16Dec w))+    , TQC.testProperty "consLength64BE-multi" $ \w ->+        pack+          ( '\x00' : '\x00' : '\x00' : '\x00'+          : '\x00' : '\x00' : '\x00' : chr (1 + L.length (show w))+          : '\x42' : show w+          )+        ===+        runConcat 1 (consLength64BE (word8 0x42 <> flush 2 <> word16Dec w))     , THU.testCase "stringUtf8" $         packUtf8 "¿Cómo estás? I am doing well." @=?-          run 1 (stringUtf8 "¿Cómo estás? I am doing well.")+          runConcat 1 (stringUtf8 "¿Cómo estás? I am doing well.")     , THU.testCase "doubleDec-A" $-        pack (show (2 :: Int)) @=? run 1 (doubleDec 2.0)+        pack (show (2 :: Int)) @=? runConcat 1 (doubleDec 2.0)     , THU.testCase "doubleDec-B" $-        pack (show (2.5 :: Double)) @=? run 1 (doubleDec 2.5)+        pack (show (2.5 :: Double)) @=? runConcat 1 (doubleDec 2.5)     , THU.testCase "doubleDec-C" $-        pack ("1e+15") @=? run 1 (doubleDec 1e15)+        pack ("1e+15") @=? runConcat 1 (doubleDec 1e15)     , THU.testCase "doubleDec-D" $-        pack ("-42") @=? run 1 (doubleDec (-42))+        pack ("-42") @=? runConcat 1 (doubleDec (-42))     , THU.testCase "doubleDec-E" $-        pack ("-8.88888888888888e+14") @=? run 1 (doubleDec (-888888888888888.8888888))+        pack ("-8.88888888888888e+14") @=? runConcat 1 (doubleDec (-888888888888888.8888888))     , THU.testCase "doubleDec-F" $-        pack ("42") @=? run 1 (doubleDec 42)+        pack ("42") @=? runConcat 1 (doubleDec 42)     , THU.testCase "doubleDec-G" $-        pack ("0") @=? run 1 (doubleDec 0)+        pack ("0") @=? runConcat 1 (doubleDec 0)     , THU.testCase "doubleDec-H" $-        pack ("0.5") @=? run 1 (doubleDec 0.5)+        pack ("0.5") @=? runConcat 1 (doubleDec 0.5)     , THU.testCase "doubleDec-I" $-        pack ("-0.5") @=? run 1 (doubleDec (-0.5))+        pack ("-0.5") @=? runConcat 1 (doubleDec (-0.5))     , THU.testCase "doubleDec-J" $-        pack ("999999999") @=? run 1 (doubleDec 999999999)+        pack ("999999999") @=? runConcat 1 (doubleDec 999999999)     , THU.testCase "doubleDec-K" $-        pack ("-99999999") @=? run 1 (doubleDec (-99999999))+        pack ("-99999999") @=? runConcat 1 (doubleDec (-99999999))     , THU.testCase "shortTextJsonString-A" $-        pack ("\"hello\"") @=? run 1 (shortTextJsonString "hello")+        pack ("\"hello\"") @=? runConcat 1 (shortTextJsonString "hello")     , THU.testCase "shortTextJsonString-B" $-        pack ("\"\\\\_\\\"_/\"") @=? run 1 (shortTextJsonString "\\_\"_/")+        pack ("\"\\\\_\\\"_/\"") @=? runConcat 1 (shortTextJsonString "\\_\"_/")     , THU.testCase "shortTextJsonString-C" $-        pack ("\"Hi\\r\\nLo\"") @=? run 1 (shortTextJsonString "Hi\r\nLo")+        pack ("\"Hi\\r\\nLo\"") @=? runConcat 1 (shortTextJsonString "Hi\r\nLo")     , THU.testCase "shortTextJsonString-D" $-        pack ("\"Hi\\u001BLo\"") @=? run 1 (shortTextJsonString "Hi\ESCLo")+        pack ("\"Hi\\u001BLo\"") @=? runConcat 1 (shortTextJsonString "Hi\ESCLo")+    , THU.testCase "word-16-tree" $+        Word16Tree.expectedSmall @=? runConcat 1+          (Word16Tree.encode Word16Tree.exampleSmall)+    , THU.testCase "byteArray-small" $+        let a = replicateByte 3 0x50+            b = replicateByte 5 0x51+         in mconcat [a,b] @=? runConcat 1+              ( byteArray a <> byteArray b )+    , THU.testCase "byteArray-big" $+        let a = replicateByte 2105 0x50+            b = replicateByte 725 0x51+            c = replicateByte 900 0x52+            d = replicateByte 800 0x53+            e = replicateByte 700 0x54+            f = replicateByte 950 0x55+            g = replicateByte 975 0x56+            h = replicateByte 3000 0x57+            i = replicateByte 125 0x58+         in mconcat [a,b,c,d,e,f,g,h,i] @=? runConcat 1+              ( byteArray a <> byteArray b <> byteArray c <>+                byteArray d <> byteArray e <> byteArray f <>+                byteArray g <> byteArray h <> byteArray i+              )+    , TQC.testProperty "word16ArrayLE" $ \(xs :: [Word16]) ->+        let ys = Exts.fromList xs :: PrimArray Word16+         in runConcat 1 (foldMap word16LE xs)+            ===+            runConcat 1 (word16ArrayLE ys 0 (Prelude.length xs))+    , TQC.testProperty "word16ArrayBE" $ \(xs :: [Word16]) ->+        let ys = Exts.fromList xs :: PrimArray Word16+         in runConcat 1 (foldMap word16BE xs)+            ===+            runConcat 1 (word16ArrayBE ys 0 (Prelude.length xs))+    , TQC.testProperty "word32ArrayLE" $ \(xs :: [Word32]) ->+        let ys = Exts.fromList xs :: PrimArray Word32+         in runConcat 1 (foldMap word32LE xs)+            ===+            runConcat 1 (word32ArrayLE ys 0 (Prelude.length xs))+    , TQC.testProperty "word32ArrayBE" $ \(xs :: [Word32]) ->+        let ys = Exts.fromList xs :: PrimArray Word32+         in runConcat 1 (foldMap word32BE xs)+            ===+            runConcat 1 (word32ArrayBE ys 0 (Prelude.length xs))+    , TQC.testProperty "word64ArrayLE" $ \(xs :: [Word64]) ->+        let ys = Exts.fromList xs :: PrimArray Word64+         in runConcat 1 (foldMap word64LE xs)+            ===+            runConcat 1 (word64ArrayLE ys 0 (Prelude.length xs))+    , TQC.testProperty "word64ArrayBE" $ \(xs :: [Word64]) ->+        let ys = Exts.fromList xs :: PrimArray Word64+         in runConcat 1 (foldMap word64BE xs)+            ===+            runConcat 1 (word64ArrayBE ys 0 (Prelude.length xs))     ]   , testGroup "alternate"     [ TQC.testProperty "HexWord64" $ \x y ->-        run 1+        runConcat 1           (  fromBounded Nat.constant (HexWord64.word64PaddedUpperHex x)           <> fromBounded Nat.constant (HexWord64.word64PaddedUpperHex y)           )@@ -106,28 +176,20 @@     ]   ] +replicateByte :: Int -> Word8 -> ByteArray+replicateByte n w = runST $ do+  m <- PM.newByteArray n+  PM.setByteArray m 0 n w+  PM.unsafeFreezeByteArray m+ pack :: String -> ByteArray pack = Exts.fromList . map (fromIntegral @Int @Word8 . ord)  packUtf8 :: String -> ByteArray packUtf8 = Exts.fromList . ByteString.unpack . TE.encodeUtf8 . T.pack --- This is used to test pasteArrayST-runArray ::-     (a -> Builder) -- ^ Builder-  -> V.Vector a -- ^ Elements to serialize-  -> ByteArray -- ^ Number of elements serialized, serialization-runArray f !xs = runST $ do-  let go !v0 !sz !chunks = if V.null v0-        then pure (mconcat (L.reverse chunks))-        else do-          arr <- PM.newByteArray sz-          (v1,MutableBytes _ off _) <- pasteArrayST (MutableBytes arr 0 sz) f v0-          -- If nothing was serialized, we need a bigger buffer-          let szNext = if V.length v0 == V.length v1 then sz + 1 else sz-          c <- PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray arr off-          go v1 szNext (c : chunks)-  go xs 1 []- showWord64PaddedUpperHex :: Word64 -> String showWord64PaddedUpperHex = printf "%016X" ++runConcat :: Int -> Builder -> ByteArray+runConcat n = Chunks.concat . run n