bytebuild (empty) → 0.3.4.0

raw patch · 14 files changed

+3228/−0 lines, 14 filesdep +QuickCheckdep +basedep +bytebuildsetup-changed

Dependencies added: QuickCheck, base, bytebuild, byteslice, bytestring, gauge, natural-arithmetic, primitive, primitive-checked, primitive-offset, primitive-unlifted, quickcheck-classes, run-st, tasty, tasty-hunit, tasty-quickcheck, text, text-short, vector, wide-word

Files

• CHANGELOG.md +94/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• bench/Cell.hs +32/−0
• bench/Main.hs +80/−0
• bench/SimpleCsv.hs +31/−0
• bytebuild.cabal +107/−0
• common/HexWord64.hs +50/−0
• common/Word16Tree.hs +84/−0
• src/Data/Bytes/Builder.hs +1045/−0
• src/Data/Bytes/Builder/Bounded.hs +1043/−0
• src/Data/Bytes/Builder/Bounded/Unsafe.hs +62/−0
• src/Data/Bytes/Builder/Unsafe.hs +260/−0
• test/Main.hs +308/−0

@@ -0,0 +1,94 @@+# Revision history for bytebuild++Note: Prior to version 0.3.4.0, this library was named+`small-bytearray-builder`, not `bytebuild`. The library+`small-bytearray-builder` is now just a compatibility shim+to ease the migration process.++## 0.3.4.0 -- 2020-02-27++* Rename the library from `small-bytearray-builder` to `bytebuild`, and+  move modules from the `Data.ByteArray` namespace to the `Data.Bytes`+  namespace. This is not considered a breaking change since+  `small-bytearray-builder` continues to exist as a compatibility shim,+  reexporting the modules with their old names.+* Add `wordPaddedDec4`.+* Add `reversedOnto` and `commitsOntoChunks`.+* Add `ascii(2|3|4|5|6)`.+* Add `cstringLen` unbounded builder.+* Add `copy2`.++## 0.3.3.0 -- 2020-02-10++* Add `word64PaddedLowerHex` and `word32PaddedLowerHex`+* Add `word256Array{LE,BE}` and `word256{LE,BE}`+* Add `word{128,256}Padded{Lower,Upper}Hex`++## 0.3.2.0 -- 2020-01-20++* Add `putMany`, which allows pasting into the same mutable byte+  array over and over.+* Add `consLength`.+* Add `putManyConsLength`, useful for chunked HTTP encoding.+* Add `runOnto`+* Add `Data.Bytes.Chunks.length`+* Add `wordPaddedDec2` and `wordPaddedDec9`.+* Add `word8PaddedLowerHex`.++## 0.3.1.0 -- 2019-11-20++* Add big-endian and little-endian parsers for `Word128`. This includes+  both the single and multiple element variants.+* Export `reverseCommitsOntoChunks` from the `Unsafe` module.+* Add `Semigroup` and `Monoid` instances for `Chunks`.+* Add `consLengthLE32`.+* Add `fromEffect` to the unsafe interface.++## 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`.+  This is technically a breaking change, but it was only+  exported by accident. So, with this release, we will technically+  violate PVP, and the previous release will be deprecated on hackage.+* Add more functions for encoding unsigned words: `word16PaddedLowerHex`,+  `word16LowerHex`, `word16UpperHex`, `word8LowerHex`.+* Unroll loop for `word8Dec`.++## 0.2.0.0 -- 2019-09-04++* Use `natural-arithmetic` to make manipulation of bounds possible.+* Add more functions for encoding numbers. This includes+  `word8/16/32/64` and `int8/16/32/64`.+* Rename the modules.+* Correct a serious error in the implementation of `bytes`.+* Make `pasteGrowST` accept an initial offset.+* Add a `pasteGrowST` for length-indexed builders.+* Add function for rendering floating-point numbers in a slightly+  inaccurate way.+* Add functions for encoding `ShortText` as UTF-8 and as a JSON string.++## 0.1.1.0 -- 2019-07-30++* Add several additional functions for encoding numbers.++## 0.1.0.0 -- 2019-06-25++* First version

@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++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 Andrew Martin 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,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 ]+  ]+

@@ -0,0 +1,80 @@+{-# 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.Bytes.Builder as B+import qualified Data.Bytes.Builder.Bounded as U++import qualified Cell+import qualified SimpleCsv+import qualified HexWord64+import qualified Word16Tree++main :: IO ()+main = defaultMain+  [ bgroup "w64"+    [ bgroup "hex"+      [ 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+    ]+  ]++w64s :: Word64s+w64s = Word64s+  0xde2b8a480cf77113+  0x48f1668ca2a68b45+  0xd262fbaa0b2f473c+  0xbab20547f4919d9f+  0xb7ec16121704db43+  0x9c259f5bfa90e1eb+  0xd451eca11d9873ad+  0xbd927e8d4c879d02++data Word64s = Word64s+  !Word64 !Word64 !Word64 !Word64+  !Word64 !Word64 !Word64 !Word64++encodeHexWord64s :: Word64s -> ByteArray+{-# noinline encodeHexWord64s #-}+encodeHexWord64s (Word64s a b c d e f g h) = U.run Nat.constant $+  U.word64PaddedUpperHex a `U.append`+  U.word64PaddedUpperHex b `U.append`+  U.word64PaddedUpperHex c `U.append`+  U.word64PaddedUpperHex d `U.append`+  U.word64PaddedUpperHex e `U.append`+  U.word64PaddedUpperHex f `U.append`+  U.word64PaddedUpperHex g `U.append`+  U.word64PaddedUpperHex h++encodeHexWord64sLoop :: Word64s -> ByteArray+{-# noinline encodeHexWord64sLoop #-}+encodeHexWord64sLoop (Word64s a b c d e f g h) = U.run Nat.constant $+  HexWord64.word64PaddedUpperHex a `U.append`+  HexWord64.word64PaddedUpperHex b `U.append`+  HexWord64.word64PaddedUpperHex c `U.append`+  HexWord64.word64PaddedUpperHex d `U.append`+  HexWord64.word64PaddedUpperHex e `U.append`+  HexWord64.word64PaddedUpperHex f `U.append`+  HexWord64.word64PaddedUpperHex g `U.append`+  HexWord64.word64PaddedUpperHex h+

@@ -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.Bytes.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,107 @@+cabal-version: 2.2+name: bytebuild+version: 0.3.4.0+synopsis: Serialize to a small byte arrays+description:+  This is similar to the builder facilities provided by+  `Data.ByteString.Builder`. It is intended to be used in+  situations where the following apply:+  .+  * An individual entity will be serialized as a small+    number of bytes (less than 512).+  .+  * A large number (more than 32) of entities will be serialized+    one after another without anything between them.+  .+  Unlike builders from the `bytestring` package, these builders+  do not track their state when they run out of space. A builder+  that runs out of space simply aborts and is rerun at the beginning+  of the next chunk. This strategy for building is suitable for most+  CSVs and several line protocols (carbon, InfluxDB, etc.).+  +homepage: https://github.com/byteverse/bytebuild+bug-reports: https://github.com/byteverse/bytebuild/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2019 Andrew Martin+category: Data+extra-source-files: CHANGELOG.md++flag checked+  manual: True+  description: Add bounds-checking to primitive array operations+  default: False++library+  exposed-modules:+    Data.Bytes.Builder+    Data.Bytes.Builder.Unsafe+    Data.Bytes.Builder.Bounded+    Data.Bytes.Builder.Bounded.Unsafe+  reexported-modules:+    Data.Bytes.Chunks+  build-depends:+    , base >=4.12.0.0 && <5+    , byteslice >=0.2 && <0.3+    , bytestring >=0.10.8.2 && <0.11+    , natural-arithmetic >=0.1 && <0.2+    , primitive-offset >=0.2 && <0.3+    , primitive-unlifted >=0.1.2 && <0.2+    , run-st >=0.1 && <0.2+    , text-short >=0.1.3 && <0.2+    , wide-word >=0.1.0.9 && <0.2+  if flag(checked)+    build-depends: primitive-checked >= 0.7 && <0.8+  else+    build-depends: primitive >= 0.7 && <0.8+  ghc-options: -Wall -O2+  hs-source-dirs: src+  default-language: Haskell2010++test-suite test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test, common+  main-is: Main.hs+  ghc-options: -O2 -Wall+  other-modules:+    HexWord64+    Word16Tree+  build-depends:+    , QuickCheck >=2.13.1 && <2.14+    , base >=4.12.0.0 && <5+    , bytebuild+    , byteslice+    , bytestring+    , natural-arithmetic+    , primitive+    , primitive-unlifted >=0.1.2+    , quickcheck-classes >=0.6.4+    , tasty >=1.2.3 && <1.3+    , tasty-hunit >=0.10.0.2 && <0.11+    , tasty-quickcheck >=0.10.1 && <0.11+    , text >=1.2 && <1.3+    , vector+    , wide-word >=0.1.0.9 && <0.2++benchmark bench+  type: exitcode-stdio-1.0+  build-depends:+    , base+    , bytebuild+    , gauge >= 0.2.4+    , natural-arithmetic+    , primitive+    , 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

@@ -0,0 +1,50 @@+{-# language BangPatterns #-}+{-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language UnboxedTuples #-}+{-# language MagicHash #-}+{-# language PolyKinds #-}+{-# language TypeApplications #-}++module HexWord64+  ( word64PaddedUpperHex+  ) where++-- We have to jump through some hoops to manually do worker-wrapper+-- since CPR doesn't work on nested products. Sadly, even with all+-- the hoop jumping, the explicit loop used here is still outperformed+-- by just inlining the loop.++import GHC.ST (ST(ST))+import Data.Bits+import Data.Bytes.Builder.Bounded.Unsafe (Builder,construct)+import Data.Primitive+import Data.Word+import GHC.Exts++import qualified Control.Monad.Primitive as PM++type ST# s (a :: TYPE (r :: RuntimeRep)) = State# s -> (# State# s, a #)++word64PaddedUpperHex :: Word64 -> Builder 16+word64PaddedUpperHex w = construct $ \a b -> ST+  (\s0 -> case word64PaddedUpperHexLoop w 60 a b s0 of+    (# s1, i #) -> (# s1, I# i #)+  )++word64PaddedUpperHexLoop :: forall s. Word64 -> Int -> MutableByteArray s -> Int -> ST# s Int#+word64PaddedUpperHexLoop !w !shiftAmount !arr !i@(I# i#) s0 = if shiftAmount >= 0+  then case PM.internal @(ST s) (writeByteArray arr i (toHexUpper (unsafeShiftR w shiftAmount))) s0 of+    (# s1, (_ :: ()) #) -> word64PaddedUpperHexLoop w (shiftAmount - 4) arr (i + 1) s1+  else (# s0, i# #)++toHexUpper :: Word64 -> Word8+toHexUpper w' = fromIntegral+    $ (complement theMask .&. loSolved)+  .|. (theMask .&. hiSolved)+  where+  w = w' .&. 0xF+  -- This is all ones if the value was >= 10+  theMask = (1 .&. unsafeShiftR (w - 10) 63) - 1+  loSolved = w + 48+  hiSolved = w + 55

@@ -0,0 +1,84 @@+{-# language BangPatterns #-}++module Word16Tree+  ( Word16Tree+  , encode+  , exampleSmall+  , example2000+  , example9000+  , expectedSmall+  ) where++import Data.Bytes.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))

@@ -0,0 +1,1045 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Data.Bytes.Builder+  ( -- * Bounded Primitives+    Builder+  , fromBounded+    -- * Evaluation+  , run+  , runOnto+  , reversedOnto+  , putMany+  , putManyConsLength+    -- * Materialized Byte Sequences+  , bytes+  , copy+  , copy2+  , insert+  , byteArray+  , shortByteString+  , shortTextUtf8+  , shortTextJsonString+  , cstring+  , cstringLen+  , stringUtf8+    -- * Encode Integral Types+    -- ** Human-Readable+  , word64Dec+  , word32Dec+  , word16Dec+  , word8Dec+  , wordDec+  , int64Dec+  , int32Dec+  , int16Dec+  , int8Dec+  , intDec+    -- * Unsigned Words+    -- ** 64-bit+  , word64PaddedUpperHex+    -- ** 32-bit+  , word32PaddedUpperHex+    -- ** 16-bit+  , word16PaddedUpperHex+  , word16PaddedLowerHex+  , word16LowerHex+  , word16UpperHex+    -- ** 8-bit+  , word8PaddedUpperHex+  , word8LowerHex+  , ascii+  , ascii2+  , ascii3+  , ascii4+  , ascii5+  , ascii6+  , char+    -- ** Machine-Readable+    -- *** One+  , word8+    -- **** Big Endian+  , word256BE+  , word128BE+  , word64BE+  , word32BE+  , word16BE+  , int64BE+  , int32BE+  , int16BE+    -- **** Little Endian+  , word256LE+  , word128LE+  , word64LE+  , word32LE+  , word16LE+  , int64LE+  , int32LE+  , int16LE+    -- *** Many+  , word8Array+    -- **** Big Endian+  , word16ArrayBE+  , word32ArrayBE+  , word64ArrayBE+  , word128ArrayBE+  , word256ArrayBE+  , int64ArrayBE+  , int32ArrayBE+  , int16ArrayBE+    -- **** Little Endian+  , word16ArrayLE+  , word32ArrayLE+  , word64ArrayLE+  , word128ArrayLE+  , word256ArrayLE+  , int64ArrayLE+  , int32ArrayLE+  , int16ArrayLE+    -- ** Prefixing with Length+  , consLength+  , consLength32LE+  , consLength32BE+  , consLength64BE+    -- * Encode Floating-Point Types+    -- ** Human-Readable+  , doubleDec+    -- * Control+  , flush+  ) where++import Control.Exception (SomeException,toException)+import Control.Monad.ST (ST,runST)+import Control.Monad.IO.Class (MonadIO,liftIO)+import Data.Bytes.Builder.Unsafe (Builder(Builder))+import Data.Bytes.Builder.Unsafe (BuilderState(BuilderState),pasteIO)+import Data.Bytes.Builder.Unsafe (Commits(Initial,Mutable,Immutable))+import Data.Bytes.Builder.Unsafe (reverseCommitsOntoChunks)+import Data.Bytes.Builder.Unsafe (commitsOntoChunks)+import Data.Bytes.Builder.Unsafe (stringUtf8,cstring)+import Data.Bytes.Builder.Unsafe (addCommitsLength,copyReverseCommits)+import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.Bytes.Chunks (Chunks(ChunksNil))+import Data.Bytes.Types (Bytes(Bytes),MutableBytes(MutableBytes))+import Data.Char (ord)+import Data.Foldable (foldlM)+import Data.Int (Int64,Int32,Int16,Int8)+import Data.Primitive (ByteArray(..),MutableByteArray(..),PrimArray(..))+import Data.Text.Short (ShortText)+import Data.WideWord (Word128,Word256)+import Data.Word (Word64,Word32,Word16,Word8)+import Foreign.C.String (CStringLen)+import GHC.ByteOrder (ByteOrder(BigEndian,LittleEndian),targetByteOrder)+import GHC.Exts (Int(I#),Char(C#),Int#,State#,ByteArray#,(>=#))+import GHC.Exts (RealWorld,MutableByteArray#,(+#),(-#),(<#))+import GHC.IO (IO(IO),stToIO)+import GHC.ST (ST(ST))++import qualified Arithmetic.Nat as Nat+import qualified Arithmetic.Types as Arithmetic+import qualified Data.Bytes.Builder.Bounded as Bounded+import qualified Data.Bytes.Builder.Bounded.Unsafe as UnsafeBounded+import qualified Data.Primitive as PM+import qualified Data.Text.Short as TS+import qualified GHC.Exts as Exts++-- | Run a builder.+run ::+     Int -- ^ Size of initial chunk (use 4080 if uncertain)+  -> Builder -- ^ Builder+  -> Chunks+run !hint bldr = runOnto hint bldr ChunksNil++-- | Run a builder. The resulting chunks are consed onto the+-- beginning of an existing sequence of chunks.+runOnto ::+     Int -- ^ Size of initial chunk (use 4080 if uncertain)+  -> Builder -- ^ Builder+  -> Chunks+  -> Chunks+runOnto hint@(I# hint# ) (Builder f) cs0 = 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 #)+  reverseCommitsOntoChunks cs0 cs++-- | Variant of 'runOnto' that conses the additional chunks+-- in reverse order. +reversedOnto :: +     Int -- ^ Size of initial chunk (use 4080 if uncertain)+  -> Builder -- ^ Builder+  -> Chunks+  -> Chunks+reversedOnto hint@(I# hint# ) (Builder f) cs0 = 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 cs0 cs++-- | Run a builder against lots of elements. This fills the same+-- underlying buffer over and over again. Do not let the argument to+-- the callback escape from the callback (i.e. do not write it to an+-- @IORef@). Also, do not @unsafeFreezeByteArray@ any of the mutable+-- byte arrays in the callback. The intent is that the callback will+-- write the buffer out.+putMany :: Foldable f+  => Int -- ^ Size of shared chunk (use 8176 if uncertain)+  -> (a -> Builder) -- ^ Value builder+  -> f a -- ^ Collection of values+  -> (MutableBytes RealWorld -> IO b) -- ^ Consume chunks.+  -> IO ()+{-# inline putMany #-}+putMany hint0 g xs cb = do+  MutableByteArray buf0 <- PM.newByteArray hint+  BuilderState bufZ offZ _ cmtsZ <- foldlM+    (\st0 a -> do+      st1@(BuilderState buf off _ cmts) <- pasteIO (g a) st0+      case cmts of+        Initial -> if I# off < threshold+          then pure st1+          else do+            _ <- cb (MutableBytes (MutableByteArray buf) 0 (I# off))+            pure (BuilderState buf0 0# hint# Initial)+        _ -> do+          let total = addCommitsLength (I# off) cmts+              doff0 = total - I# off+          large <- PM.newByteArray total+          stToIO (PM.copyMutableByteArray large doff0 (MutableByteArray buf) 0 (I# off))+          r <- stToIO (copyReverseCommits large doff0 cmts)+          case r of+            0 -> do+              _ <- cb (MutableBytes large 0 total)+              pure (BuilderState buf0 0# hint# Initial)+            _ -> IO (\s0 -> Exts.raiseIO# putManyError s0)+    ) (BuilderState buf0 0# hint# Initial) xs+  _ <- case cmtsZ of+    Initial -> cb (MutableBytes (MutableByteArray bufZ) 0 (I# offZ))+    _ -> IO (\s0 -> Exts.raiseIO# putManyError s0)+  pure ()+  where+  !hint@(I# hint#) = max hint0 8+  !threshold = div (hint * 3) 4++putManyError :: SomeException+{-# noinline putManyError #-}+putManyError = toException+  (userError "bytebuild: putMany implementation error")++-- | Variant of 'putMany' that prefixes each pushed array of chunks+-- with the number of bytes that the chunks in each batch required.+-- (This excludes the bytes required to encode the length itself.)+-- This is useful for chunked HTTP encoding.+putManyConsLength :: (Foldable f, MonadIO m)+  => Arithmetic.Nat n -- ^ Number of bytes used by the serialization of the length+  -> (Int -> Bounded.Builder n) -- ^ Length serialization function+  -> Int -- ^ Size of shared chunk (use 8176 if uncertain)+  -> (a -> Builder) -- ^ Value builder+  -> f a -- ^ Collection of values+  -> (MutableBytes RealWorld -> m b) -- ^ Consume chunks.+  -> m ()+{-# inline putManyConsLength #-}+putManyConsLength n buildSize hint g xs cb = do+  let !(I# n# ) = Nat.demote n+  let !(I# actual# ) = max hint (I# n# )+  let !threshold = div (I# actual# * 3) 4+  MutableByteArray buf0 <- liftIO (PM.newByteArray (I# actual# ))+  BuilderState bufZ offZ _ cmtsZ <- foldlM+    (\st0 a -> do+      st1@(BuilderState buf off _ cmts) <- liftIO (pasteIO (g a) st0)+      case cmts of+        Initial -> if I# off < threshold+          then pure st1+          else do+            let !dist = off -# n#+            _ <- liftIO $ stToIO $ UnsafeBounded.pasteST+              (buildSize (fromIntegral (I# dist)))+              (MutableByteArray buf0) 0+            _ <- cb (MutableBytes (MutableByteArray buf) 0 (I# off))+            pure (BuilderState buf0 n# (actual# -# n# ) Initial)+        _ -> do+          let !dist = commitDistance1 buf0 n# buf off cmts+          _ <- liftIO $ stToIO $ UnsafeBounded.pasteST+            (buildSize (fromIntegral (I# dist)))+            (MutableByteArray buf0) 0+          let total = addCommitsLength (I# off) cmts+              doff0 = total - I# off+          large <- liftIO (PM.newByteArray total)+          liftIO (stToIO (PM.copyMutableByteArray large doff0 (MutableByteArray buf) 0 (I# off)))+          r <- liftIO (stToIO (copyReverseCommits large doff0 cmts))+          case r of+            0 -> do+              _ <- cb (MutableBytes large 0 total)+              pure (BuilderState buf0 n# (actual# -# n# ) Initial)+            _ -> liftIO (IO (\s0 -> Exts.raiseIO# putManyError s0))+    ) (BuilderState buf0 n# (actual# -# n# ) Initial) xs+  _ <- case cmtsZ of+    Initial -> do+      let !distZ = offZ -# n#+      _ <- liftIO $ stToIO $ UnsafeBounded.pasteST+        (buildSize (fromIntegral (I# distZ)))+        (MutableByteArray buf0)+        0+      cb (MutableBytes (MutableByteArray bufZ) 0 (I# offZ))+    _ -> liftIO (IO (\s0 -> Exts.raiseIO# putManyError s0))+  pure ()++-- | Convert a bounded builder to an unbounded one. If the size+-- is a constant, use @Arithmetic.Nat.constant@ as the first argument+-- to let GHC conjure up this value for you.+fromBounded ::+     Arithmetic.Nat n+  -> Bounded.Builder n+  -> Builder+{-# inline fromBounded #-}+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. Implemented with 'bytes'.+byteArray :: ByteArray -> Builder+byteArray a = bytes (Bytes a 0 (PM.sizeofByteArray a))++-- | Create a builder from a short bytestring. Implemented with 'bytes'.+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 (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 C string with explicit length. The builder+-- must be executed before the C string is freed.+cstringLen :: CStringLen -> Builder+cstringLen (Exts.Ptr src#, I# slen# ) = Builder+  (\buf0 off0 len0 cs0 s0 -> case len0 <# slen# of+    1# -> case Exts.newByteArray# newSz s0 of+        (# s1, buf1 #) -> case Exts.copyAddrToByteArray# src# buf1 0# slen# s1 of+          s2 -> (# s2, buf1, slen#, newSz -# slen#, Mutable buf0 off0 cs0 #)+    _ -> let !s1 = Exts.copyAddrToByteArray# src# buf0 off0 slen# s0 in+      (# s1, buf0, off0 +# slen#, len0 -# slen#, cs0 #)+  )+  where+  !(I# newSz) = max (I# slen#) 4080++-- | Create a builder from two byte sequences. This always results in two+-- calls to @memcpy@. This is beneficial when the byte sequences are+-- known to be small (less than 256 bytes).+copy2 :: Bytes -> Bytes -> Builder+copy2 (Bytes (ByteArray srcA# ) (I# soffA# ) (I# slenA# ))+      (Bytes (ByteArray srcB# ) (I# soffB# ) (I# slenB# )) = Builder+  (\buf0 off0 len0 cs0 s0 -> case len0 <# slen# of+    1# -> case Exts.newByteArray# newSz s0 of+        (# s1, buf1 #) -> case Exts.copyByteArray# srcA# soffA# buf1 0# slenA# s1 of+          s2 -> case Exts.copyByteArray# srcB# soffB# buf1 slenA# slenB# s2 of+            s3 -> (# s3, buf1, slen#, newSz -# slen#, Mutable buf0 off0 cs0 #)+    _ -> let !s1 = Exts.copyByteArray# srcA# soffA# buf0 off0 slenA# s0+             !s2 = Exts.copyByteArray# srcB# soffB# buf0 (off0 +# slenA# ) slenB# s1 in+      (# s2, buf0, off0 +# slen#, len0 -# slen#, cs0 #)+  )+  where+  !slen# = slenA# +# slenB#+  !(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)++word128ArrayLE :: PrimArray Word128 -> Int -> Int -> Builder+word128ArrayLE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  LittleEndian -> bytes (Bytes (ByteArray arr) (soff0 * 16) (slen0 * 16))+  BigEndian -> word128ArraySwap src soff0 slen0++word128ArrayBE :: PrimArray Word128 -> Int -> Int -> Builder+word128ArrayBE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  BigEndian -> bytes (Bytes (ByteArray arr) (soff0 * 16) (slen0 * 16))+  LittleEndian -> word128ArraySwap src soff0 slen0++word256ArrayLE :: PrimArray Word256 -> Int -> Int -> Builder+word256ArrayLE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  LittleEndian -> bytes (Bytes (ByteArray arr) (soff0 * 32) (slen0 * 32))+  BigEndian -> word256ArraySwap src soff0 slen0++word256ArrayBE :: PrimArray Word256 -> Int -> Int -> Builder+word256ArrayBE src@(PrimArray arr) soff0 slen0 = case targetByteOrder of+  BigEndian -> bytes (Bytes (ByteArray arr) (soff0 * 32) (slen0 * 32))+  LittleEndian -> word256ArraySwap src soff0 slen0++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++word128ArraySwap :: PrimArray Word128 -> Int -> Int -> Builder+word128ArraySwap src soff0 slen0 =+  fromFunction (slen0 * 16) (go (soff0 * 16) ((soff0 + slen0) * 16))+  where+  -- TODO: Perhaps we could put byteswapping functions to use+  -- rather than indexing tons of Word8s. This could be done+  -- both here and in the other swap functions. There are a+  -- decent number of tests for these array-swapping functions,+  -- which makes changing this less scary.+  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)+          v8 = PM.indexPrimArray (asWord8s src) (soff + 8)+          v9 = PM.indexPrimArray (asWord8s src) (soff + 9)+          v10 = PM.indexPrimArray (asWord8s src) (soff + 10)+          v11 = PM.indexPrimArray (asWord8s src) (soff + 11)+          v12 = PM.indexPrimArray (asWord8s src) (soff + 12)+          v13 = PM.indexPrimArray (asWord8s src) (soff + 13)+          v14 = PM.indexPrimArray (asWord8s src) (soff + 14)+          v15 = PM.indexPrimArray (asWord8s src) (soff + 15)+      PM.writeByteArray dst doff v15+      PM.writeByteArray dst (doff + 1) v14+      PM.writeByteArray dst (doff + 2) v13+      PM.writeByteArray dst (doff + 3) v12+      PM.writeByteArray dst (doff + 4) v11+      PM.writeByteArray dst (doff + 5) v10+      PM.writeByteArray dst (doff + 6) v9+      PM.writeByteArray dst (doff + 7) v8+      PM.writeByteArray dst (doff + 8) v7+      PM.writeByteArray dst (doff + 9) v6+      PM.writeByteArray dst (doff + 10) v5+      PM.writeByteArray dst (doff + 11) v4+      PM.writeByteArray dst (doff + 12) v3+      PM.writeByteArray dst (doff + 13) v2+      PM.writeByteArray dst (doff + 14) v1+      PM.writeByteArray dst (doff + 15) v0+      go (soff + 16) send dst (doff + 16)+    else pure doff++word256ArraySwap :: PrimArray Word256 -> Int -> Int -> Builder+word256ArraySwap src soff0 slen0 =+  fromFunction (slen0 * 32) (go (soff0 * 32) ((soff0 + slen0) * 32))+  where+  -- TODO: Perhaps we could put byteswapping functions to use+  -- rather than indexing tons of Word8s. This could be done+  -- both here and in the other swap functions. There are a+  -- decent number of tests for these array-swapping functions,+  -- which makes changing this less scary.+  go :: Int -> Int -> MutableByteArray s -> Int -> ST s Int+  go !soff !send !dst !doff = if soff < send+    then do+      let loop !i+            | i < 32 = do+              let v = PM.indexPrimArray (asWord8s src) (soff + i)+              PM.writeByteArray dst (doff + (31 - i)) v+              loop (i + 1)+            | otherwise = pure ()+      loop 0+      go (soff + 32) send dst (doff + 32)+    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+{-# noinline slicedUtf8TextJson #-}+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+  PM.writeByteArray marr ix (c2w a)+  PM.writeByteArray marr (ix + 1) (c2w b)++-- | Create a builder from text. The text will be UTF-8 encoded.+shortTextUtf8 :: ShortText -> Builder+shortTextUtf8 a =+  let ba = shortTextToByteArray a+   in bytes (Bytes ba 0 (PM.sizeofByteArray ba))++-- | Create a builder from text. The text will be UTF-8 encoded,+-- and JSON special characters will be escaped. Additionally, the+-- result is surrounded by double quotes. For example:+--+-- * @foo ==\> "foo"@ (no escape sequences)+-- * @\\_"_\/ ==\> "\\\\_\\"_\/"@ (escapes backslashes and quotes)+-- * @hello\<ESC\>world ==> "hello\\u001Bworld"@ (where @\<ESC\>@ is code point 0x1B)+shortTextJsonString :: ShortText -> Builder+shortTextJsonString a =+  let !(ByteArray ba) = shortTextToByteArray a+      !(I# len) = PM.sizeofByteArray (ByteArray ba)+   in slicedUtf8TextJson ba 0# len++-- | Encodes an unsigned 64-bit integer as decimal.+-- This encoding never starts with a zero unless the+-- argument was zero.+word64Dec :: Word64 -> Builder+word64Dec w = fromBounded Nat.constant (Bounded.word64Dec w)++-- | Encodes an unsigned 16-bit integer as decimal.+-- This encoding never starts with a zero unless the+-- argument was zero.+word32Dec :: Word32 -> Builder+word32Dec w = fromBounded Nat.constant (Bounded.word32Dec w)++-- | Encodes an unsigned 16-bit integer as decimal.+-- This encoding never starts with a zero unless the+-- argument was zero.+word16Dec :: Word16 -> Builder+word16Dec w = fromBounded Nat.constant (Bounded.word16Dec w)++-- | Encodes an unsigned 8-bit integer as decimal.+-- This encoding never starts with a zero unless the+-- argument was zero.+word8Dec :: Word8 -> Builder+word8Dec w = fromBounded Nat.constant (Bounded.word8Dec w)++-- | Encodes an unsigned machine-sized integer as decimal.+-- This encoding never starts with a zero unless the+-- argument was zero.+wordDec :: Word -> Builder+wordDec w = fromBounded Nat.constant (Bounded.wordDec w)++-- | Encode a double-floating-point number, using decimal notation or+-- scientific notation depending on the magnitude. This has undefined+-- behavior when representing @+inf@, @-inf@, and @NaN@. It will not+-- crash, but the generated numbers will be nonsense.+doubleDec :: Double -> Builder+doubleDec w = fromBounded Nat.constant (Bounded.doubleDec w)++-- | Encodes a signed 64-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int64Dec :: Int64 -> Builder+int64Dec w = fromBounded Nat.constant (Bounded.int64Dec w)++-- | Encodes a signed 32-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int32Dec :: Int32 -> Builder+int32Dec w = fromBounded Nat.constant (Bounded.int32Dec w)++-- | Encodes a signed 16-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int16Dec :: Int16 -> Builder+int16Dec w = fromBounded Nat.constant (Bounded.int16Dec w)++-- | Encodes a signed 8-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int8Dec :: Int8 -> Builder+int8Dec w = fromBounded Nat.constant (Bounded.int8Dec w)++-- | Encodes a signed machine-sized integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+intDec :: Int -> Builder+intDec w = fromBounded Nat.constant (Bounded.intDec w)++-- | Encode a 64-bit unsigned integer as hexadecimal, zero-padding+-- the encoding to 16 digits. This uses uppercase for the alphabetical+-- digits. For example, this encodes the number 1022 as @00000000000003FE@.+word64PaddedUpperHex :: Word64 -> Builder+word64PaddedUpperHex w =+  fromBounded Nat.constant (Bounded.word64PaddedUpperHex w)++-- | Encode a 32-bit unsigned integer as hexadecimal, zero-padding+-- the encoding to 8 digits. This uses uppercase for the alphabetical+-- digits. For example, this encodes the number 1022 as @000003FE@.+word32PaddedUpperHex :: Word32 -> Builder+word32PaddedUpperHex w =+  fromBounded Nat.constant (Bounded.word32PaddedUpperHex w)++-- | Encode a 16-bit unsigned integer as hexadecimal, zero-padding+-- the encoding to 4 digits. This uses uppercase for the alphabetical+-- digits. For example, this encodes the number 1022 as @03FE@.+word16PaddedUpperHex :: Word16 -> Builder+word16PaddedUpperHex w =+  fromBounded Nat.constant (Bounded.word16PaddedUpperHex w)++-- | Encode a 16-bit unsigned integer as hexadecimal, zero-padding+-- the encoding to 4 digits. This uses lowercase for the alphabetical+-- digits. For example, this encodes the number 1022 as @03fe@.+word16PaddedLowerHex :: Word16 -> Builder+word16PaddedLowerHex w =+  fromBounded Nat.constant (Bounded.word16PaddedLowerHex w)++-- | Encode a 16-bit unsigned integer as hexadecimal without leading+-- zeroes. This uses lowercase for the alphabetical digits. For+-- example, this encodes the number 1022 as @3fe@.+word16LowerHex :: Word16 -> Builder+word16LowerHex w =+  fromBounded Nat.constant (Bounded.word16LowerHex w)++-- | Encode a 16-bit unsigned integer as hexadecimal without leading+-- zeroes. This uses uppercase for the alphabetical digits. For+-- example, this encodes the number 1022 as @3FE@.+word16UpperHex :: Word16 -> Builder+word16UpperHex w =+  fromBounded Nat.constant (Bounded.word16UpperHex w)++-- | Encode a 16-bit unsigned integer as hexadecimal without leading+-- zeroes. This uses lowercase for the alphabetical digits. For+-- example, this encodes the number 1022 as @3FE@.+word8LowerHex :: Word8 -> Builder+word8LowerHex w =+  fromBounded Nat.constant (Bounded.word8LowerHex w)++-- | Encode a 8-bit unsigned integer as hexadecimal, zero-padding+-- the encoding to 2 digits. This uses uppercase for the alphabetical+-- digits. For example, this encodes the number 11 as @0B@.+word8PaddedUpperHex :: Word8 -> Builder+word8PaddedUpperHex w =+  fromBounded Nat.constant (Bounded.word8PaddedUpperHex w)++-- | Encode an ASCII char.+-- Precondition: Input must be an ASCII character. This is not checked.+ascii :: Char -> Builder+ascii c = fromBoundedOne (Bounded.ascii c)++-- | Encode two ASCII characters.+-- Precondition: Must be an ASCII characters. This is not checked.+ascii2 :: Char -> Char -> Builder+ascii2 a b = fromBounded Nat.constant (Bounded.ascii2 a b)++-- | Encode three ASCII characters.+-- Precondition: Must be an ASCII characters. This is not checked.+ascii3 :: Char -> Char -> Char -> Builder+ascii3 a b c = fromBounded Nat.constant (Bounded.ascii3 a b c)++-- | Encode four ASCII characters.+-- Precondition: Must be an ASCII characters. This is not checked.+ascii4 :: Char -> Char -> Char -> Char -> Builder+ascii4 a b c d = fromBounded Nat.constant (Bounded.ascii4 a b c d)++-- | Encode five ASCII characters.+-- Precondition: Must be an ASCII characters. This is not checked.+ascii5 :: Char -> Char -> Char -> Char -> Char -> Builder+ascii5 a b c d e = fromBounded Nat.constant (Bounded.ascii5 a b c d e)++-- | Encode five ASCII characters.+-- Precondition: Must be an ASCII characters. This is not checked.+ascii6 :: Char -> Char -> Char -> Char -> Char -> Char -> Builder+ascii6 a b c d e f = fromBounded Nat.constant (Bounded.ascii6 a b c d e f)++-- | Encode a UTF-8 char. This only uses as much space as is required.+char :: Char -> Builder+char c = fromBounded Nat.constant (Bounded.char c)++unST :: ST s a -> State# s -> (# State# s, a #)+unST (ST f) = f++-- | 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 32 bytes. Dump the octets of a 256-bit+-- word in a little-endian fashion.+word256LE :: Word256 -> Builder+word256LE w = fromBounded Nat.constant (Bounded.word256LE w)++-- | Requires exactly 16 bytes. Dump the octets of a 128-bit+-- word in a little-endian fashion.+word128LE :: Word128 -> Builder+word128LE w = fromBounded Nat.constant (Bounded.word128LE 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 32 bytes. Dump the octets of a 256-bit+-- word in a big-endian fashion.+word256BE :: Word256 -> Builder+word256BE w = fromBounded Nat.constant (Bounded.word256BE w)++-- | Requires exactly 16 bytes. Dump the octets of a 128-bit+-- word in a big-endian fashion.+word128BE :: Word128 -> Builder+word128BE w = fromBounded Nat.constant (Bounded.word128BE 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)++-- | Requires exactly 4 bytes. Dump the octets of a 32-bit+-- word in a big-endian fashion.+word32BE :: Word32 -> Builder+word32BE w = fromBounded Nat.constant (Bounded.word32BE w)++-- | Requires exactly 2 bytes. Dump the octets of a 16-bit+-- word in a big-endian fashion.+word16BE :: Word16 -> Builder+word16BE w = fromBounded Nat.constant (Bounded.word16BE w)++-- | Requires exactly 1 byte.+word8 :: Word8 -> Builder+word8 w = fromBoundedOne (Bounded.word8 w)++-- | Prefix a builder with the number of bytes that it requires.+consLength ::+     Arithmetic.Nat n -- ^ Number of bytes used by the serialization of the length+  -> (Int -> Bounded.Builder n) -- ^ Length serialization function+  -> Builder -- ^ Builder whose length is measured+  -> Builder+{-# inline consLength #-}+consLength !n buildSize (Builder f) = Builder $ \buf0 off0 len0 cs0 s0 ->+  -- There is actually a little bit of unsoundness here. If the number of+  -- bytes required to encode the length is greater than 4080, this will+  -- write outside the array, leading to a crash.+  let !(I# lenSz) = Nat.demote n+      !(# s1, buf1, off1, len1, cs1 #) = case len0 >=# lenSz 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 +# lenSz) (len1 -# lenSz) cs1 s1 of+        (# s2, buf2, off2, len2, cs2 #) ->+          let !dist = commitDistance1 buf1 (off1 +# lenSz) buf2 off2 cs2+              ST g = UnsafeBounded.pasteST+                (buildSize (fromIntegral (I# dist)))+                (MutableByteArray buf1)+                (I# off1)+           in case g s2 of+                (# s3, _ #) -> (# s3, buf2, off2, len2, cs2 #)++-- | Variant of 'consLength32BE' the encodes the length in+-- a little-endian fashion.+consLength32LE :: Builder -> Builder+consLength32LE = consLength Nat.constant (\x -> Bounded.word32LE (fromIntegral x))++-- | 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 = consLength Nat.constant (\x -> Bounded.word32BE (fromIntegral x))++-- | 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 = consLength Nat.constant (\x -> Bounded.word64BE (fromIntegral x))++-- Internal. This is like commitDistance, but you get to supply a+-- head of the commit list that has not yet been committed.+commitDistance1 ::+     MutableByteArray# s -- target+  -> Int# -- offset into target+  -> MutableByteArray# s -- head of array+  -> Int# -- offset into head of array+  -> Commits s+  -> Int#+commitDistance1 target offTarget buf0 offBuf cs =+  case Exts.sameMutableByteArray# target buf0 of+    1# -> offBuf -# offTarget+    _ -> commitDistance target offBuf cs -# offTarget++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+shortTextToByteArray x = case TS.toShortByteString x of+  SBS a -> ByteArray a++indexChar8Array :: ByteArray -> Int -> Char+indexChar8Array (ByteArray b) (I# i) = C# (Exts.indexCharArray# b i)++c2w :: Char -> Word8+c2w = fromIntegral . ord

@@ -0,0 +1,1043 @@+{-# language BangPatterns #-}+{-# language BinaryLiterals #-}+{-# language DataKinds #-}+{-# language KindSignatures #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeOperators #-}+{-# language UnboxedTuples #-}++-- | The functions in this module are explict about the maximum number+-- of bytes they require.+module Data.Bytes.Builder.Bounded+  ( -- * Builder+    Builder+    -- * Execute+  , run+  , pasteGrowST+    -- * Combine+  , empty+  , append+    -- * Bounds Manipulation+  , weaken+  , substitute+    -- * Encode Integral Types+    -- ** Human-Readable+  , word64Dec+  , word32Dec+  , word16Dec+  , word8Dec+  , wordDec+  , int64Dec+  , int32Dec+  , int16Dec+  , int8Dec+  , intDec+    -- * Unsigned Words+    -- ** Wide Words+  , word128PaddedLowerHex+  , word128PaddedUpperHex+  , word256PaddedLowerHex+  , word256PaddedUpperHex+    -- ** 64-bit+  , word64PaddedLowerHex+  , word64PaddedUpperHex+    -- ** 32-bit+  , word32PaddedLowerHex+  , word32PaddedUpperHex+    -- ** 16-bit+  , word16PaddedLowerHex+  , word16PaddedUpperHex+  , word16LowerHex+  , word16UpperHex+    -- ** 8-bit+  , word8PaddedLowerHex+  , word8PaddedUpperHex+  , word8LowerHex+  , ascii+  , ascii2+  , ascii3+  , ascii4+  , ascii5+  , ascii6+  , char+    -- ** Native+  , wordPaddedDec2+  , wordPaddedDec4+  , wordPaddedDec9+    -- ** Machine-Readable+    -- *** One+  , word8+    -- **** Big Endian+  , word256BE+  , word128BE+  , word64BE+  , word32BE+  , word16BE+  , int64BE+  , int32BE+  , int16BE+    -- **** Little Endian+  , word256LE+  , word128LE+  , word64LE+  , word32LE+  , word16LE+  , int64LE+  , int32LE+  , int16LE+    -- * Encode Floating-Point Types+  , doubleDec+  ) where++import Arithmetic.Types (type (<=), type (:=:))+import Control.Monad.Primitive+import Control.Monad.ST (ST)+import Control.Monad.ST.Run (runByteArrayST)+import Data.Bits+import Data.Bytes.Builder.Bounded.Unsafe (Builder(..))+import Data.Char (ord)+import Data.Primitive+import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..))+import Data.WideWord (Word128(Word128),Word256(Word256))+import GHC.Exts+import GHC.Int (Int64(I64#),Int32(I32#),Int16(I16#),Int8(I8#))+import GHC.ST (ST(ST))+import GHC.TypeLits (type (+))+import GHC.Word (Word8(W8#),Word16(W16#),Word32(W32#),Word64(W64#))++import qualified Arithmetic.Lte as Lte+import qualified Arithmetic.Nat as Nat+import qualified Arithmetic.Types as Arithmetic+import qualified Data.Bytes.Builder.Bounded.Unsafe as Unsafe+import qualified Data.Primitive as PM++-- | Execute the bounded builder. If the size is a constant,+-- use @Arithmetic.Nat.constant@ as the first argument to let+-- GHC conjure up this value for you.+run ::+     Arithmetic.Nat n+  -> Builder n -- ^ Builder+  -> ByteArray+{-# inline run #-}+run n b = runByteArrayST $ do+  arr <- newByteArray (Nat.demote n)+  len <- Unsafe.pasteST b arr 0+  shrinkMutableByteArray arr len+  unsafeFreezeByteArray arr++-- | Paste the builder into the byte array starting at offset zero.+-- This reallocates the byte array if it cannot accomodate the builder,+-- growing it by the minimum amount necessary.+pasteGrowST ::+     Arithmetic.Nat n+  -> Builder n+  -> MutableByteArrayOffset s+     -- ^ Initial buffer, used linearly. Do not reuse this argument.+  -> ST s (MutableByteArrayOffset s)+     -- ^ Final buffer that accomodated the builder.+{-# inline pasteGrowST #-}+pasteGrowST n b !(MutableByteArrayOffset{array=arr0,offset=off0}) = do+  sz0 <- PM.getSizeofMutableByteArray arr0+  let req = Nat.demote n+  let sz1 = off0 + req+  if sz1 <= sz0+    then do+      off1 <- Unsafe.pasteST b arr0 off0+      pure (MutableByteArrayOffset arr0 off1)+    else do+      arr1 <- PM.resizeMutableByteArray arr0 sz1+      off1 <- Unsafe.pasteST b arr1 off0+      pure (MutableByteArrayOffset arr1 off1)++-- | The monoidal unit of `append`+empty :: Builder 0+empty = Builder $ \_ off0 s0 -> (# s0, off0 #)++infixr 9 `append`++-- | Concatenate two builders.+append :: Builder m -> Builder n -> Builder (m + n)+append (Builder f) (Builder g) =+  Builder $ \arr off0 s0 -> case f arr off0 s0 of+    (# s1, r #) -> g arr r s1++-- | Weaken the bound on the maximum number of bytes required. For example,+-- to use two builders with unequal bounds in a disjunctive setting:+--+-- > import qualified Arithmetic.Lte as Lte+-- >+-- > buildNumber :: Either Double Word64 -> Builder 32+-- > buildNumber = \case+-- >   Left d  -> doubleDec d+-- >   Right w -> weaken (Lte.constant @19 @32) (word64Dec w)+weaken :: forall m n. (m <= n) -> Builder m -> Builder n+weaken !_ (Builder f) = Builder f++-- | Replace the upper bound on size with an equal number.+substitute :: forall m n. (m :=: n) -> Builder m -> Builder n+substitute !_ (Builder f) = Builder f++-- | Encode a double-floating-point number, using decimal notation or+-- scientific notation depending on the magnitude. This has undefined+-- behavior when representing @+inf@, @-inf@, and @NaN@. It will not+-- crash, but the generated numbers will be nonsense.+doubleDec :: Double -> Builder 32+doubleDec (D# d) = Builder (\arr off0 s0 -> doubleDec# d arr off0 s0)++-- | Requires up to 19 bytes. Encodes an unsigned 64-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+word64Dec :: Word64 -> Builder 19+word64Dec (W64# w) = wordCommonDec# w++-- | Requires up to 10 bytes. Encodes an unsigned 32-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+word32Dec :: Word32 -> Builder 10+word32Dec (W32# w) = wordCommonDec# w++-- | Requires up to 5 bytes. Encodes an unsigned 16-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+word16Dec :: Word16 -> Builder 5+word16Dec (W16# w) = wordCommonDec# w++-- | Requires up to 3 bytes. Encodes an unsigned 8-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+word8Dec :: Word8 -> Builder 3+word8Dec (W8# w) =+  -- We unroll the loop when encoding Word8s. This speeds things+  -- up IPv4 encoding by about 10% in the @ip@ library. We can+  -- encode Word8s at twice this speed by using a lookup table.+  -- However, I (Andrew Martin) am concerned that although lookup+  -- table perform very well in microbenchmarks, they can thrash+  -- L1 cache in real applications.+  word8Dec# w++-- | Requires up to 19 bytes. Encodes an unsigned machine-sized integer+-- as decimal. This encoding never starts with a zero unless the argument+-- was zero.+wordDec :: Word -> Builder 19+wordDec (W# w) = wordCommonDec# w++-- | Requires up to 20 bytes. Encodes a signed 64-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int64Dec :: Int64 -> Builder 20+int64Dec (I64# w) = intCommonDec# w++-- | Requires up to 11 bytes. Encodes a signed 32-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int32Dec :: Int32 -> Builder 11+int32Dec (I32# w) = intCommonDec# w++-- | Requires up to 6 bytes. Encodes a signed 16-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int16Dec :: Int16 -> Builder 6+int16Dec (I16# w) = intCommonDec# w++-- | Requires up to 4 bytes. Encodes a signed 8-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int8Dec :: Int8 -> Builder 4+int8Dec (I8# w) = intCommonDec# w++-- | Requires up to 20 bytes. Encodes a signed machine-sized integer+-- as decimal. This encoding never starts with a zero unless the+-- argument was zero. Negative numbers are preceded by a minus sign.+-- Positive numbers are not preceded by anything.+intDec :: Int -> Builder 20+intDec (I# w) = intCommonDec# w++word8Dec# :: Word# -> Builder 3+{-# noinline word8Dec# #-}+word8Dec# w# = Unsafe.construct $ \arr off0 -> do+  let !(I# off0# ) = off0+      !(!x,!ones) = quotRem w 10+      !(hundreds@(W# hundreds# ),tens@(W# tens# )) = quotRem x 10+  writeByteArray arr off0 (fromIntegral (hundreds + 0x30) :: Word8)+  let !hasHundreds = gtWord# hundreds# 0##+      !off1@(I# off1# ) = I# (off0# +# hasHundreds)+  writeByteArray arr off1 (fromIntegral (tens + 0x30) :: Word8)+  let !off2 = I# (off1# +# (orI# hasHundreds (gtWord# tens# 0## )))+  writeByteArray arr off2 (fromIntegral (ones + 0x30) :: Word8)+  pure (off2 + 1)+  where+  w = W# w#++-- Requires a number of bytes that is bounded by the size of+-- the word. This is only used internally.+wordCommonDec# :: Word# -> Builder n+{-# noinline wordCommonDec# #-}+wordCommonDec# w# = Unsafe.construct $ \arr off0 -> if w /= 0+  then internalWordLoop arr off0 (W# w#)+  else do+    writeByteArray arr off0 (c2w '0')+    pure (off0 + 1)+  where+  w = W64# w#++internalWordLoop :: MutableByteArray s -> Int -> Word -> ST s Int+{-# inline internalWordLoop #-}+internalWordLoop arr off0 x0 = go off0 x0 where+  go !off !(x :: Word) = if x > 0+    then do+      let (y,z) = quotRem x 10+      writeByteArray arr off (fromIntegral (z + 0x30) :: Word8)+      go (off + 1) y+    else do+      reverseBytes arr off0 (off - 1)+      pure off++-- Requires up to 20 bytes. Can be less depending on what the+-- size of the argument is known to be. Unsafe.+intCommonDec# :: Int# -> Builder n+{-# noinline intCommonDec# #-}+intCommonDec# w# = Unsafe.construct $ \arr off0 -> case compare w 0 of+  GT -> internalWordLoop arr off0 (fromIntegral w)+  EQ -> do+    writeByteArray arr off0 (c2w '0')+    pure (off0 + 1)+  LT -> do+    writeByteArray arr off0 (c2w '-')+    internalWordLoop arr (off0 + 1) (fromIntegral (negate w))+  where+  w = I64# w#++-- Convert a number between 0 and 16 to the ASCII+-- representation of its hexadecimal character.+-- The use of fromIntegral causes us to incur an+-- unneeded bitmask. This actually needs a Word64+-- argument.+toHexUpper :: Word -> Word8+toHexUpper w' = fromIntegral+    $ (complement theMask .&. loSolved)+  .|. (theMask .&. hiSolved)+  where+  w = w' .&. 0xF+  -- This is all ones if the value was >= 10+  theMask = (1 .&. unsafeShiftR (w - 10) 63) - 1+  loSolved = w + 48+  hiSolved = w + 55++toHexLower :: Word -> Word8+toHexLower w' = fromIntegral+    $ (complement theMask .&. loSolved)+  .|. (theMask .&. hiSolved)+  where+  w = w' .&. 0xF+  -- This is all ones if the value was >= 10+  theMask = (1 .&. unsafeShiftR (w - 10) 63) - 1+  loSolved = w + 48+  hiSolved = w + 87++-- | Requires exactly 64 bytes. Encodes a 256-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 64 digits. This uses+-- lowercase for the alphabetical digits.+word256PaddedLowerHex :: Word256 -> Builder 64+word256PaddedLowerHex (Word256 w192 w128 w64 w0) =+           word64PaddedLowerHex w192+  `append` word64PaddedLowerHex w128+  `append` word64PaddedLowerHex w64+  `append` word64PaddedLowerHex w0++-- | Requires exactly 64 bytes. Encodes a 256-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 64 digits. This uses+-- uppercase for the alphabetical digits.+word256PaddedUpperHex :: Word256 -> Builder 64+word256PaddedUpperHex (Word256 w192 w128 w64 w0) =+           word64PaddedUpperHex w192+  `append` word64PaddedUpperHex w128+  `append` word64PaddedUpperHex w64+  `append` word64PaddedUpperHex w0+++-- | Requires exactly 32 bytes. Encodes a 128-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 32 digits. This uses+-- lowercase for the alphabetical digits.+word128PaddedLowerHex :: Word128 -> Builder 32+word128PaddedLowerHex (Word128 w64 w0) =+           word64PaddedLowerHex w64+  `append` word64PaddedLowerHex w0++-- | Requires exactly 32 bytes. Encodes a 128-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 32 digits. This uses+-- uppercase for the alphabetical digits.+word128PaddedUpperHex :: Word128 -> Builder 32+word128PaddedUpperHex (Word128 w64 w0) =+           word64PaddedUpperHex w64+  `append` word64PaddedUpperHex w0+++-- | Requires exactly 16 bytes. Encodes a 64-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 16 digits. This uses+-- uppercase for the alphabetical digits. For example, this encodes the+-- number 1022 as @00000000000003FE@.+word64PaddedUpperHex :: Word64 -> Builder 16+word64PaddedUpperHex (W64# w) = word64PaddedUpperHex# w++-- | Requires exactly 16 bytes. Encodes a 64-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 16 digits. This uses+-- lowercase for the alphabetical digits. For example, this encodes the+-- number 1022 as @00000000000003fe@.+word64PaddedLowerHex :: Word64 -> Builder 16+word64PaddedLowerHex (W64# w) = word64PaddedLowerHex# w++-- | Requires exactly 8 bytes. Encodes a 32-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 8 digits. This uses+-- uppercase for the alphabetical digits.+word32PaddedUpperHex :: Word32 -> Builder 8+word32PaddedUpperHex (W32# w) = word32PaddedUpperHex# w++-- | Requires exactly 8 bytes. Encodes a 32-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 8 digits. This uses+-- lowercase for the alphabetical digits.+word32PaddedLowerHex :: Word32 -> Builder 8+word32PaddedLowerHex (W32# w) = word32PaddedLowerHex# w++-- | Requires exactly 4 bytes. Encodes a 16-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 4 digits. This uses+-- uppercase for the alphabetical digits.+--+-- >>> word16PaddedUpperHex 0xab0+-- 0AB0+word16PaddedUpperHex :: Word16 -> Builder 4+word16PaddedUpperHex (W16# w) = word16PaddedUpperHex# w++-- | Requires exactly 4 bytes. Encodes a 16-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 4 digits. This uses+-- lowercase for the alphabetical digits.+--+-- >>> word16PaddedLowerHex 0xab0+-- 0ab0+word16PaddedLowerHex :: Word16 -> Builder 4+word16PaddedLowerHex (W16# w) = word16PaddedLowerHex# w++-- | Requires at most 4 bytes. Encodes a 16-bit unsigned integer as+-- hexadecimal. No leading zeroes are displayed. Letters are presented+-- in lowercase. If the number is zero, a single zero digit is used.+--+-- >>> word16LowerHex 0xab0+-- ab0+word16LowerHex :: Word16 -> Builder 4+word16LowerHex (W16# w) = word16LowerHex# w++-- | Requires at most 4 bytes. Encodes a 16-bit unsigned integer as+-- hexadecimal. No leading zeroes are displayed. Letters are presented+-- in uppercase. If the number is zero, a single zero digit is used.+--+-- >>> word16UpperHex 0xab0+-- AB0+word16UpperHex :: Word16 -> Builder 4+word16UpperHex (W16# w) = word16UpperHex# w++-- | Requires at most 2 bytes. Encodes a 8-bit unsigned integer as+-- hexadecimal. No leading zeroes are displayed. If the number is zero,+-- a single zero digit is used.+word8LowerHex :: Word8 -> Builder 2+word8LowerHex (W8# w) = word8LowerHex# w++-- | Requires exactly 2 bytes. Encodes a 8-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 2 digits. This uses+-- uppercase for the alphabetical digits.+word8PaddedUpperHex :: Word8 -> Builder 2+word8PaddedUpperHex (W8# w) = word8PaddedUpperHex# w++-- | Requires exactly 2 bytes. Encodes a 8-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 2 digits. This uses+-- lowercase for the alphabetical digits.+word8PaddedLowerHex :: Word8 -> Builder 2+word8PaddedLowerHex (W8# w) = word8PaddedLowerHex# w++-- TODO: Is it actually worth unrolling this loop. I suspect that it+-- might not be. Benchmark this.+word64PaddedUpperHex# :: Word# -> Builder 16+{-# noinline word64PaddedUpperHex# #-}+word64PaddedUpperHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexUpper (unsafeShiftR w 60))+  writeByteArray arr (off + 1) (toHexUpper (unsafeShiftR w 56))+  writeByteArray arr (off + 2) (toHexUpper (unsafeShiftR w 52))+  writeByteArray arr (off + 3) (toHexUpper (unsafeShiftR w 48))+  writeByteArray arr (off + 4) (toHexUpper (unsafeShiftR w 44))+  writeByteArray arr (off + 5) (toHexUpper (unsafeShiftR w 40))+  writeByteArray arr (off + 6) (toHexUpper (unsafeShiftR w 36))+  writeByteArray arr (off + 7) (toHexUpper (unsafeShiftR w 32))+  writeByteArray arr (off + 8) (toHexUpper (unsafeShiftR w 28))+  writeByteArray arr (off + 9) (toHexUpper (unsafeShiftR w 24))+  writeByteArray arr (off + 10) (toHexUpper (unsafeShiftR w 20))+  writeByteArray arr (off + 11) (toHexUpper (unsafeShiftR w 16))+  writeByteArray arr (off + 12) (toHexUpper (unsafeShiftR w 12))+  writeByteArray arr (off + 13) (toHexUpper (unsafeShiftR w 8))+  writeByteArray arr (off + 14) (toHexUpper (unsafeShiftR w 4))+  writeByteArray arr (off + 15) (toHexUpper (unsafeShiftR w 0))+  pure (off + 16)+  where+  w = W# w#++-- TODO: Is it actually worth unrolling this loop. I suspect that it+-- might not be. Benchmark this.+word64PaddedLowerHex# :: Word# -> Builder 16+{-# noinline word64PaddedLowerHex# #-}+word64PaddedLowerHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexLower (unsafeShiftR w 60))+  writeByteArray arr (off + 1) (toHexLower (unsafeShiftR w 56))+  writeByteArray arr (off + 2) (toHexLower (unsafeShiftR w 52))+  writeByteArray arr (off + 3) (toHexLower (unsafeShiftR w 48))+  writeByteArray arr (off + 4) (toHexLower (unsafeShiftR w 44))+  writeByteArray arr (off + 5) (toHexLower (unsafeShiftR w 40))+  writeByteArray arr (off + 6) (toHexLower (unsafeShiftR w 36))+  writeByteArray arr (off + 7) (toHexLower (unsafeShiftR w 32))+  writeByteArray arr (off + 8) (toHexLower (unsafeShiftR w 28))+  writeByteArray arr (off + 9) (toHexLower (unsafeShiftR w 24))+  writeByteArray arr (off + 10) (toHexLower (unsafeShiftR w 20))+  writeByteArray arr (off + 11) (toHexLower (unsafeShiftR w 16))+  writeByteArray arr (off + 12) (toHexLower (unsafeShiftR w 12))+  writeByteArray arr (off + 13) (toHexLower (unsafeShiftR w 8))+  writeByteArray arr (off + 14) (toHexLower (unsafeShiftR w 4))+  writeByteArray arr (off + 15) (toHexLower (unsafeShiftR w 0))+  pure (off + 16)+  where+  w = W# w#++word32PaddedUpperHex# :: Word# -> Builder 8+{-# noinline word32PaddedUpperHex# #-}+word32PaddedUpperHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexUpper (unsafeShiftR w 28))+  writeByteArray arr (off + 1) (toHexUpper (unsafeShiftR w 24))+  writeByteArray arr (off + 2) (toHexUpper (unsafeShiftR w 20))+  writeByteArray arr (off + 3) (toHexUpper (unsafeShiftR w 16))+  writeByteArray arr (off + 4) (toHexUpper (unsafeShiftR w 12))+  writeByteArray arr (off + 5) (toHexUpper (unsafeShiftR w 8))+  writeByteArray arr (off + 6) (toHexUpper (unsafeShiftR w 4))+  writeByteArray arr (off + 7) (toHexUpper (unsafeShiftR w 0))+  pure (off + 8)+  where+  w = W# w#++word32PaddedLowerHex# :: Word# -> Builder 8+{-# noinline word32PaddedLowerHex# #-}+word32PaddedLowerHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexLower (unsafeShiftR w 28))+  writeByteArray arr (off + 1) (toHexLower (unsafeShiftR w 24))+  writeByteArray arr (off + 2) (toHexLower (unsafeShiftR w 20))+  writeByteArray arr (off + 3) (toHexLower (unsafeShiftR w 16))+  writeByteArray arr (off + 4) (toHexLower (unsafeShiftR w 12))+  writeByteArray arr (off + 5) (toHexLower (unsafeShiftR w 8))+  writeByteArray arr (off + 6) (toHexLower (unsafeShiftR w 4))+  writeByteArray arr (off + 7) (toHexLower (unsafeShiftR w 0))+  pure (off + 8)+  where+  w = W# w#++-- Not sure if it is beneficial to inline this. We just let+-- GHC make the decision. Open an issue on github if this is+-- a problem.+word16PaddedUpperHex# :: Word# -> Builder 4+word16PaddedUpperHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexUpper (unsafeShiftR w 12))+  writeByteArray arr (off + 1) (toHexUpper (unsafeShiftR w 8))+  writeByteArray arr (off + 2) (toHexUpper (unsafeShiftR w 4))+  writeByteArray arr (off + 3) (toHexUpper (unsafeShiftR w 0))+  pure (off + 4)+  where+  w = W# w#++word16PaddedLowerHex# :: Word# -> Builder 4+word16PaddedLowerHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexLower (unsafeShiftR w 12))+  writeByteArray arr (off + 1) (toHexLower (unsafeShiftR w 8))+  writeByteArray arr (off + 2) (toHexLower (unsafeShiftR w 4))+  writeByteArray arr (off + 3) (toHexLower (unsafeShiftR w 0))+  pure (off + 4)+  where+  w = W# w#++word12PaddedLowerHex# :: Word# -> Builder 3+word12PaddedLowerHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexLower (unsafeShiftR w 8))+  writeByteArray arr (off + 1) (toHexLower (unsafeShiftR w 4))+  writeByteArray arr (off + 2) (toHexLower (unsafeShiftR w 0))+  pure (off + 3)+  where+  w = W# w#++word12PaddedUpperHex# :: Word# -> Builder 3+word12PaddedUpperHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexUpper (unsafeShiftR w 8))+  writeByteArray arr (off + 1) (toHexUpper (unsafeShiftR w 4))+  writeByteArray arr (off + 2) (toHexUpper (unsafeShiftR w 0))+  pure (off + 3)+  where+  w = W# w#++-- Definitely want this to inline. It's maybe a dozen instructions total.+word8PaddedUpperHex# :: Word# -> Builder 2+{-# inline word8PaddedUpperHex# #-}+word8PaddedUpperHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexUpper (unsafeShiftR w 4))+  writeByteArray arr (off + 1) (toHexUpper (unsafeShiftR w 0))+  pure (off + 2)+  where+  w = W# w#++word8PaddedLowerHex# :: Word# -> Builder 2+{-# inline word8PaddedLowerHex# #-}+word8PaddedLowerHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexLower (unsafeShiftR w 4))+  writeByteArray arr (off + 1) (toHexLower (unsafeShiftR w 0))+  pure (off + 2)+  where+  w = W# w#++word4PaddedLowerHex# :: Word# -> Builder 1+{-# inline word4PaddedLowerHex# #-}+word4PaddedLowerHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexLower w)+  pure (off + 1)+  where+  w = W# w#++word4PaddedUpperHex# :: Word# -> Builder 1+{-# inline word4PaddedUpperHex# #-}+word4PaddedUpperHex# w# = Unsafe.construct $ \arr off -> do+  writeByteArray arr off (toHexUpper w)+  pure (off + 1)+  where+  w = W# w#++word16UpperHex# :: Word# -> Builder 4+word16UpperHex# w#+  | w <= 0xF = weaken Lte.constant (word4PaddedUpperHex# w#)+  | w <= 0xFF = weaken Lte.constant (word8PaddedUpperHex# w#)+  | w <= 0xFFF = weaken Lte.constant (word12PaddedUpperHex# w#)+  | otherwise = word16PaddedUpperHex# w#+  where+  w = W# w#++word16LowerHex# :: Word# -> Builder 4+word16LowerHex# w#+  | w <= 0xF = weaken Lte.constant (word4PaddedLowerHex# w#)+  | w <= 0xFF = weaken Lte.constant (word8PaddedLowerHex# w#)+  | w <= 0xFFF = weaken Lte.constant (word12PaddedLowerHex# w#)+  | otherwise = word16PaddedLowerHex# w#+  where+  w = W# w#++-- Precondition: argument less than 256+word8LowerHex# :: Word# -> Builder 2+word8LowerHex# w#+  | w <= 0xF = weaken Lte.constant (word4PaddedLowerHex# w#)+  | otherwise = weaken Lte.constant (word8PaddedLowerHex# w#)+  where+  w = W# w#++-- | Encode a number less than 100 as a decimal number, zero-padding it to+-- two digits. For example: 0 is encoded as @00@, 5 is encoded as @05@, and+-- 73 is encoded as @73@.+--+-- Precondition: Argument must be less than 100. Failure to satisfy this+-- precondition will not result in a segfault, but the resulting bytes are+-- undefined. The implemention uses a heuristic for division that is inaccurate+-- for large numbers.+wordPaddedDec2 :: Word -> Builder 2+wordPaddedDec2 !w = Unsafe.construct $ \arr off -> do+  let d1 = approxDiv10 w+      d2 = w - (10 * d1)+  writeByteArray arr off (unsafeWordToWord8 (d1 + 48))+  writeByteArray arr (off + 1) (unsafeWordToWord8 (d2 + 48))+  pure (off + 2)++-- | Encode a number less than 10000 as a decimal number, zero-padding it to+-- two digits. For example: 0 is encoded as @0000@, 5 is encoded as @0005@,+-- and 73 is encoded as @0073@.+--+-- Precondition: Argument must be less than 10000. Failure to satisfy this+-- precondition will not result in a segfault, but the resulting bytes are+-- undefined. The implemention uses a heuristic for division that is inaccurate+-- for large numbers.+wordPaddedDec4 :: Word -> Builder 4+wordPaddedDec4 !w = Unsafe.construct $ \arr off -> do+  putRem10+    (putRem10 $ putRem10 $ putRem10 +     (\_ _ _ -> pure ())+    ) arr (off + 3) w+  pure (off + 4)++-- | Encode a number less than 1e9 as a decimal number, zero-padding it to+-- nine digits. For example: 0 is encoded as @000000000@ and 5 is encoded as+-- @000000005@.+--+-- Precondition: Argument must be less than 1e9. Failure to satisfy this+-- precondition will not result in a segfault, but the resulting bytes are+-- undefined. The implemention uses a heuristic for division that is inaccurate+-- for large numbers.+wordPaddedDec9 :: Word -> Builder 9+wordPaddedDec9 !w = Unsafe.construct $ \arr off -> do+  putRem10+    (putRem10 $ putRem10 $ putRem10 $ putRem10 $ putRem10 $+     putRem10 $ putRem10 $ putRem10+     (\_ _ _ -> pure ())+    ) arr (off + 8) w+  pure (off + 9)++putRem10 :: (MutableByteArray s -> Int -> Word -> ST s a) -> MutableByteArray s -> Int -> Word -> ST s a+{-# inline putRem10 #-}+putRem10 andThen arr off dividend = do+  let quotient = approxDiv10 dividend+      remainder = dividend - (10 * quotient)+  writeByteArray arr off (unsafeWordToWord8 (remainder + 48))+  andThen arr (off - 1) quotient++-- | Encode an ASCII character.+-- Precondition: Input must be an ASCII character. This is not checked.+ascii :: Char -> Builder 1+ascii (C# c) = Unsafe.construct $ \(MutableByteArray arr) (I# off) -> do+  primitive_ (writeCharArray# arr off c)+  pure (I# (off +# 1# ))++-- | Encode two ASCII characters. Precondition: Must be an ASCII characters.+-- This is not checked.+ascii2 :: Char -> Char -> Builder 2+ascii2 (C# c0) (C# c1) = Unsafe.construct $ \(MutableByteArray arr) (I# off) -> do+  primitive_ (writeCharArray# arr off c0)+  primitive_ (writeCharArray# arr (off +# 1# ) c1)+  pure (I# (off +# 2# ))++-- | Encode three ASCII characters. Precondition: Must be an ASCII characters.+-- This is not checked.+ascii3 :: Char -> Char -> Char -> Builder 3+ascii3 (C# c0) (C# c1) (C# c2) = Unsafe.construct $ \(MutableByteArray arr) (I# off) -> do+  primitive_ (writeCharArray# arr off c0)+  primitive_ (writeCharArray# arr (off +# 1# ) c1)+  primitive_ (writeCharArray# arr (off +# 2# ) c2)+  pure (I# (off +# 3# ))++-- | Encode four ASCII characters. Precondition: Must be an ASCII characters.+-- This is not checked.+ascii4 :: Char -> Char -> Char -> Char -> Builder 4+ascii4 (C# c0) (C# c1) (C# c2) (C# c3) = Unsafe.construct $ \(MutableByteArray arr) (I# off) -> do+  primitive_ (writeCharArray# arr off c0)+  primitive_ (writeCharArray# arr (off +# 1# ) c1)+  primitive_ (writeCharArray# arr (off +# 2# ) c2)+  primitive_ (writeCharArray# arr (off +# 3# ) c3)+  pure (I# (off +# 4# ))++-- | Encode five ASCII characters. Precondition: Must be an ASCII characters.+-- This is not checked.+ascii5 :: Char -> Char -> Char -> Char -> Char -> Builder 5+ascii5 (C# c0) (C# c1) (C# c2) (C# c3) (C# c4) = Unsafe.construct $ \(MutableByteArray arr) (I# off) -> do+  primitive_ (writeCharArray# arr off c0)+  primitive_ (writeCharArray# arr (off +# 1# ) c1)+  primitive_ (writeCharArray# arr (off +# 2# ) c2)+  primitive_ (writeCharArray# arr (off +# 3# ) c3)+  primitive_ (writeCharArray# arr (off +# 4# ) c4)+  pure (I# (off +# 5# ))++-- | Encode six ASCII characters. Precondition: Must be an ASCII characters.+-- This is not checked.+ascii6 :: Char -> Char -> Char -> Char -> Char -> Char -> Builder 6+ascii6 (C# c0) (C# c1) (C# c2) (C# c3) (C# c4) (C# c5) = Unsafe.construct $ \(MutableByteArray arr) (I# off) -> do+  primitive_ (writeCharArray# arr off c0)+  primitive_ (writeCharArray# arr (off +# 1# ) c1)+  primitive_ (writeCharArray# arr (off +# 2# ) c2)+  primitive_ (writeCharArray# arr (off +# 3# ) c3)+  primitive_ (writeCharArray# arr (off +# 4# ) c4)+  primitive_ (writeCharArray# arr (off +# 5# ) c5)+  pure (I# (off +# 6# ))++-- | Encode a character as UTF-8. This only uses as much space as is required.+char :: Char -> Builder 4+char c+  | codepoint < 0x80 = Unsafe.construct $ \arr off -> do+      writeByteArray arr off (unsafeWordToWord8 codepoint)+      pure (off + 1)+  | codepoint < 0x800 = Unsafe.construct $ \arr off -> do+      writeByteArray arr off       (unsafeWordToWord8 (byteTwoOne codepoint))+      writeByteArray arr (off + 1) (unsafeWordToWord8 (byteTwoTwo codepoint))+      return (off + 2)+  | codepoint >= 0xD800 && codepoint < 0xE000 = Unsafe.construct $ \arr off -> do+      -- Codepoint U+FFFD+      writeByteArray arr off       (0xEF :: Word8)+      writeByteArray arr (off + 1) (0xBF :: Word8)+      writeByteArray arr (off + 2) (0xBD :: Word8)+      return (off + 3)+  | codepoint < 0x10000 = Unsafe.construct $ \arr off -> do+      writeByteArray arr off       (unsafeWordToWord8 (byteThreeOne codepoint))+      writeByteArray arr (off + 1) (unsafeWordToWord8 (byteThreeTwo codepoint))+      writeByteArray arr (off + 2) (unsafeWordToWord8 (byteThreeThree codepoint))+      return (off + 3)+  | otherwise = Unsafe.construct $ \arr off -> do+      writeByteArray arr off       (unsafeWordToWord8 (byteFourOne codepoint))+      writeByteArray arr (off + 1) (unsafeWordToWord8 (byteFourTwo codepoint))+      writeByteArray arr (off + 2) (unsafeWordToWord8 (byteFourThree codepoint))+      writeByteArray arr (off + 3) (unsafeWordToWord8 (byteFourFour codepoint))+      return (off + 4)++  where+    codepoint :: Word+    codepoint = fromIntegral (ord c)++    -- precondition: codepoint is less than 0x800+    byteTwoOne :: Word -> Word+    byteTwoOne w = unsafeShiftR w 6 .|. 0b11000000++    byteTwoTwo :: Word -> Word+    byteTwoTwo w = (w .&. 0b00111111) .|. 0b10000000++    -- precondition: codepoint is less than 0x1000+    byteThreeOne :: Word -> Word+    byteThreeOne w = unsafeShiftR w 12 .|. 0b11100000++    byteThreeTwo :: Word -> Word+    byteThreeTwo w = (0b00111111 .&. unsafeShiftR w 6) .|. 0b10000000++    byteThreeThree :: Word -> Word+    byteThreeThree w = (w .&. 0b00111111) .|. 0b10000000++    -- precondition: codepoint is less than 0x110000+    byteFourOne :: Word -> Word+    byteFourOne w = unsafeShiftR w 18 .|. 0b11110000++    byteFourTwo :: Word -> Word+    byteFourTwo w = (0b00111111 .&. unsafeShiftR w 12) .|. 0b10000000++    byteFourThree :: Word -> Word+    byteFourThree w = (0b00111111 .&. unsafeShiftR w 6) .|. 0b10000000++    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))++word128LE :: Word128 -> Builder 16+word128LE (Word128 hi lo) = append (word64LE lo) (word64LE hi)++word128BE :: Word128 -> Builder 16+word128BE (Word128 hi lo) = append (word64BE hi) (word64BE lo)++word256LE :: Word256 -> Builder 32+word256LE (Word256 hi mhi mlo lo) = word64LE lo `append` word64LE mlo `append` word64LE mhi `append` word64LE hi++word256BE :: Word256 -> Builder 32+word256BE (Word256 hi mhi mlo lo) = word64BE hi `append` word64BE mhi `append` word64BE mlo `append` word64BE lo++-- | 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+  writeByteArray arr (off    ) (fromIntegral @Word64 @Word8 (unsafeShiftR w 56))+  writeByteArray arr (off + 1) (fromIntegral @Word64 @Word8 (unsafeShiftR w 48))+  writeByteArray arr (off + 2) (fromIntegral @Word64 @Word8 (unsafeShiftR w 40))+  writeByteArray arr (off + 3) (fromIntegral @Word64 @Word8 (unsafeShiftR w 32))+  writeByteArray arr (off + 4) (fromIntegral @Word64 @Word8 (unsafeShiftR w 24))+  writeByteArray arr (off + 5) (fromIntegral @Word64 @Word8 (unsafeShiftR w 16))+  writeByteArray arr (off + 6) (fromIntegral @Word64 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off + 7) (fromIntegral @Word64 @Word8 w)+  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+  writeByteArray arr (off    ) (fromIntegral @Word32 @Word8 (unsafeShiftR w 24))+  writeByteArray arr (off + 1) (fromIntegral @Word32 @Word8 (unsafeShiftR w 16))+  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.+word16BE :: Word16 -> Builder 2+word16BE w = Unsafe.construct $ \arr off -> do+  writeByteArray arr (off    ) (fromIntegral @Word16 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off + 1) (fromIntegral @Word16 @Word8 w)+  pure (off + 2)++word8 :: Word8 -> Builder 1+word8 w = Unsafe.construct $ \arr off -> do+  writeByteArray arr off w+  pure (off + 1)++-- Reverse the bytes in the designated slice. This takes+-- an inclusive start offset and an inclusive end offset.+reverseBytes :: MutableByteArray s -> Int -> Int -> ST s ()+{-# inline reverseBytes #-}+reverseBytes arr begin end = go begin end where+  go ixA ixB = if ixA < ixB+    then do+      a :: Word8 <- readByteArray arr ixA+      b :: Word8 <- readByteArray arr ixB+      writeByteArray arr ixA b+      writeByteArray arr ixB a+      go (ixA + 1) (ixB - 1)+    else pure ()++c2w :: Char -> Word8+c2w = fromIntegral . ord++shrinkMutableByteArray :: MutableByteArray s -> Int -> ST s ()+shrinkMutableByteArray (MutableByteArray arr) (I# sz) =+  primitive_ (shrinkMutableByteArray# arr sz)++-- This is adapted from androider's code in https://stackoverflow.com/a/7097567+-- The checks for infinity and NaN have been removed. Note that this is a little+-- inaccurate. This is very visible when encoding a number like 2.25, which+-- is perfectly represented as an IEEE 754 floating point number but is goofed+-- up by this function.+-- If you modify this function, please take a took at the resulting core.+-- It currently performs no boxing at all, and it would be nice to keep+-- it that way.+doubleDec# :: forall s.+  Double# -> MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)+{-# noinline doubleDec# #-}+doubleDec# d# marr# off# s0 = unIntST s0 $ do+  let marr = MutableByteArray marr#+  let d0 = D# d#+  let off0 = I# off#+  if d0 == 0+    then do+      writeByteArray marr off0 (c2w '0')+      pure (off0 + 1)+    else do+      let neg = d0 < 0+      off1 <- if neg+        then do+          writeByteArray marr off0 (c2w '-')+          pure (off0 + 1)+        else pure off0+      let d1 = abs d0+      let mag0 = floor (logBase10 d1) :: Int+      let useExp = (mag0 >= 14 || (neg && mag0 >= 9) || mag0 <= (-9))+      -- This straightforward adaptation of the C code is awkward+      -- in Haskell. Binding the triple where mag1 might not even+      -- get used is strange.+      let !(!d2,!mag1,!mag0A) = if useExp+            then+              let mag0' = if mag0 < 0 then mag0 - 1 else mag0+               in (d1 / (10.0 ** fromIntegral @Int @Double mag0'), mag0', 0)+            else (d1,0,mag0)+      let mag0B = if mag0A < 1 then 0 else mag0A+      let goNum :: Double -> Int -> Int -> ST s Int+          goNum !dA0 !mag !offA0 = if (dA0 > doublePrecision || mag >= 0)+            then do+              let weight = 10.0 ** (fromIntegral @Int @Double mag)+              -- We should actually check weight with isinf here,+              -- but we do not.+              (dA1,offA1) <- if weight > 0+                then do+                  -- TODO: use a better floor function+                  let digit = ((floor :: Double -> Int) (dA0 / weight))+                  let discard = fromIntegral @Int @Double digit * weight+                  writeByteArray marr offA0+                    (fromIntegral @Int @Word8 (digit + ord '0'))+                  pure (dA0 - discard,offA0 + 1)+                else pure (dA0,offA0)+              offA2 <- if mag == 0 && dA1 > 0+                then do+                  writeByteArray marr offA1 (c2w '.')+                  pure (offA1 + 1)+                else pure offA1+              goNum dA1 (mag - 1) offA2+            else pure offA0+      !off2 <- goNum d2 mag0B off1+      off3 <- if useExp+        then do+          writeByteArray marr off2 (c2w 'e')+          !mag2 <- if mag1 > 0+            then do+              writeByteArray marr (off2 + 1) (c2w '+')+              pure mag1+            else do+              writeByteArray marr (off2 + 1) (c2w '-')+              pure (-mag1)+          let goMag !mag !off = if mag > 0+                then do+                  let (q,r) = quotRem mag 10+                  writeByteArray marr off (fromIntegral @Int @Word8 (ord '0' + r))+                  goMag q (off + 1)+                else pure off+          !off3 <- goMag mag2 (off2 + 2)+          reverseBytes marr (off2 + 2) (off3 - 1)+          pure off3+        else pure off2+      pure off3++doublePrecision :: Double+doublePrecision = 0.00000000000001++unIntST :: State# s -> ST s Int -> (# State# s, Int# #)+{-# inline unIntST #-}+unIntST s0 (ST f) = case f s0 of+  (# s1, I# i #) -> (# s1, i #)++-- This is slightly inaccurate. I think this can actually cause+-- problems in some situations. The log10 function from C would+-- be better. The inaccuracy here cause the logarithm to be slightly+-- larger than it should be. There might actually be a simple way to+-- fix this by just using recursion to compute it. We just floor the+-- result anyway. Hmm...+logBase10 :: Double -> Double+logBase10 d = log d / 2.30258509299++-- Based on C code from https://stackoverflow.com/a/5558614+-- For numbers less than 1073741829, this gives a correct answer.+approxDiv10 :: Word -> Word+approxDiv10 !n = unsafeShiftR (0x1999999A * n) 32++unsafeWordToWord8 :: Word -> Word8+unsafeWordToWord8 (W# w) = W8# w

@@ -0,0 +1,62 @@+{-# language DataKinds #-}+{-# language GADTSyntax #-}+{-# language KindSignatures #-}+{-# language MagicHash #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Data.Bytes.Builder.Bounded.Unsafe+  ( -- * Types+    Builder(..)+    -- * Construct+  , construct+    -- * Run+  , pasteST+  , pasteIO+  ) where++import Data.Kind (Type)+import Data.Primitive (MutableByteArray(..))+import GHC.Exts (Int(I#),RealWorld,Int#,State#,MutableByteArray#)+import GHC.IO (stToIO)+import GHC.ST (ST(ST))+import GHC.TypeLits (Nat)++-- | A builder parameterized by the maximum number of bytes it uses+-- when executed.+newtype Builder :: Nat -> Type where+   Builder ::+        (forall s. MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)) +        -- ^ This function takes a buffer, an offset, and a number of remaining bytes.+        --   It returns the new offset.+     -> Builder n+   ++-- | 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. MutableByteArray s -> Int -> ST s Int) -> Builder n+{-# inline construct #-}+construct f = Builder+  $ \arr off s0 ->+    case unST (f (MutableByteArray arr) (I# off)) s0 of+      (# s1, (I# n) #) -> (# s1, n #)++-- | This function does not enforce the known upper bound on the+-- size. It is up to the user to do this.+pasteST :: Builder n -> MutableByteArray s -> Int -> ST s Int+{-# inline pasteST #-}+pasteST (Builder f) (MutableByteArray arr) (I# off) =+  ST $ \s0 -> case f arr off s0 of+    (# s1, r #) -> (# s1, (I# r) #)++-- | This function does not enforce the known upper bound on the+-- size. It is up to the user to do this.+pasteIO :: Builder n -> MutableByteArray RealWorld -> Int -> IO Int+{-# inline pasteIO #-}+pasteIO b m off = stToIO (pasteST b m off)++unST :: ST s a -> State# s -> (# State# s, a #)+unST (ST f) = f+

@@ -0,0 +1,260 @@+{-# language BangPatterns #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Data.Bytes.Builder.Unsafe+  ( -- * Types+    Builder(..)+  , BuilderState(..)+  , Commits(..)+    -- * Execution+  , pasteST+  , pasteIO+    -- * Construction+  , fromEffect+    -- * Finalization+  , reverseCommitsOntoChunks+  , commitsOntoChunks+  , copyReverseCommits+  , addCommitsLength+    -- * Safe Functions+    -- | These functions are actually completely safe, but they are defined+    -- here because they are used by typeclass instances. Import them from+    -- @Data.Bytes.Builder@ instead.+  , stringUtf8+  , cstring+  ) where++import Control.Monad.Primitive (primitive_)+import Data.Bytes.Chunks (Chunks(ChunksCons))+import Data.Bytes.Types (Bytes(Bytes))+import Data.Primitive (MutableByteArray(..),ByteArray(..))+import Foreign.C.String (CString)+import GHC.Base (unpackCString#,unpackCStringUtf8#)+import GHC.Exts ((-#),(+#),(>#),(>=#))+import GHC.Exts (Addr#,ByteArray#,MutableByteArray#,Int(I#),Ptr(Ptr))+import GHC.Exts (RealWorld,IsString,Int#,State#)+import GHC.ST (ST(ST))+import GHC.IO (stToIO)++import qualified Data.Bytes.Builder.Bounded as Bounded+import qualified Data.Bytes.Builder.Bounded.Unsafe as UnsafeBounded+import qualified Data.Primitive as PM+import qualified GHC.Exts as Exts++-- | An unmaterialized sequence of bytes that may be pasted+-- into a mutable byte array.+newtype Builder+  = 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+    )++data BuilderState s = BuilderState+  (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 are already committed++-- | Run a builder, performing an in-place update on the state.+-- The @BuilderState@ argument must not be reused after being passed+-- to this function. That is, its use must be affine.+pasteST :: Builder -> BuilderState s -> ST s (BuilderState s)+{-# inline pasteST #-}+pasteST (Builder f) (BuilderState buf off len cmts) = ST $ \s0 ->+  case f buf off len cmts s0 of+    (# s1, buf1, off1, len1, cmts1 #) ->+      (# s1, BuilderState buf1 off1 len1 cmts1 #)++-- | Variant of 'pasteST' that runs in 'IO'.+pasteIO :: Builder -> BuilderState RealWorld -> IO (BuilderState RealWorld)+{-# inline pasteIO #-}+pasteIO b st = stToIO (pasteST b st)++instance IsString Builder where+  {-# inline fromString #-}+  fromString = stringUtf8++instance Semigroup Builder where+  {-# inline (<>) #-}+  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 $ \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++-- | Add the total number of bytes in the commits to first+-- argument.+addCommitsLength :: Int -> Commits s -> Int+addCommitsLength !acc Initial = acc+addCommitsLength !acc (Immutable _ _ x cs) = addCommitsLength (acc + I# x) cs+addCommitsLength !acc (Mutable _ x cs) = addCommitsLength (acc + I# x) cs++-- | Cons the chunks from a list of @Commits@ onto an initial+-- @Chunks@ list (this argument is often @ChunksNil@). This reverses+-- the order of the chunks, which is desirable since builders assemble+-- @Commits@ with the chunks backwards. This performs an in-place shrink+-- and freezes any mutable byte arrays it encounters. Consequently,+-- these must not be reused.+reverseCommitsOntoChunks :: Chunks -> Commits s -> ST s Chunks+reverseCommitsOntoChunks !xs Initial = pure xs+reverseCommitsOntoChunks !xs (Immutable arr off len cs) =+  reverseCommitsOntoChunks (ChunksCons (Bytes (ByteArray arr) (I# off) (I# len)) xs) cs+reverseCommitsOntoChunks !xs (Mutable buf len cs) = case len of+  -- Skip over empty byte arrays.+  0# -> reverseCommitsOntoChunks xs cs+  _ -> do+    shrinkMutableByteArray (MutableByteArray buf) (I# len)+    arr <- PM.unsafeFreezeByteArray (MutableByteArray buf)+    reverseCommitsOntoChunks (ChunksCons (Bytes arr 0 (I# len)) xs) cs++-- | Variant of 'reverseCommitsOntoChunks' that does not reverse+-- the order of the commits. Since commits are built backwards by+-- consing, this means that the chunks appended to the front will+-- be backwards. Within each chunk, however, the bytes will be in+-- the correct order.+--+-- Unlike 'reverseCommitsOntoChunks', this function is not tail+-- recursive.+commitsOntoChunks :: Chunks -> Commits s -> ST s Chunks+commitsOntoChunks !xs0 cs0 = go cs0+  where+  go Initial = pure xs0+  go (Immutable arr off len cs) = do+    xs <- go cs+    pure $! ChunksCons (Bytes (ByteArray arr) (I# off) (I# len)) xs+  go (Mutable buf len cs) = case len of+    -- Skip over empty byte arrays.+    0# -> go cs+    _ -> do+      shrinkMutableByteArray (MutableByteArray buf) (I# len)+      arr <- PM.unsafeFreezeByteArray (MutableByteArray buf)+      xs <- go cs+      pure $! ChunksCons (Bytes arr 0 (I# len)) xs++-- | Copy the contents of the chunks into a mutable array, reversing+-- the order of the chunks.+-- Precondition: The destination must have enough space to house the+-- contents. This is not checked.+copyReverseCommits ::+     MutableByteArray s -- ^ Destination+  -> Int -- ^ Destination range successor+  -> Commits s -- ^ Source+  -> ST s Int+{-# inline copyReverseCommits #-}+copyReverseCommits (MutableByteArray dst) (I# off) cs = ST+  (\s0 -> case copyReverseCommits# dst off cs s0 of+    (# s1, nextOff #) -> (# s1, I# nextOff #)+  )++copyReverseCommits# ::+     MutableByteArray# s+  -> Int#+  -> Commits s+  -> State# s+  -> (# State# s, Int# #)+copyReverseCommits# _ off Initial s0 = (# s0, off #)+copyReverseCommits# marr prevOff (Mutable arr sz cs) s0 =+  let !off = prevOff -# sz in+  case Exts.copyMutableByteArray# arr 0# marr off sz s0 of+    s1 -> copyReverseCommits# marr off cs s1+copyReverseCommits# marr prevOff (Immutable arr soff sz cs) s0 =+  let !off = prevOff -# sz in+  case Exts.copyByteArray# arr soff marr off sz s0 of+    s1 -> copyReverseCommits# marr off cs s1++-- | Create a builder from a cons-list of 'Char'. These+-- are be UTF-8 encoded.+stringUtf8 :: String -> Builder+{-# inline stringUtf8 #-}+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 (goCString cs)++goString :: String+  -> MutableByteArray# s -> Int# -> Int# -> Commits s+  -> State# s -> (# State# s, MutableByteArray# s, Int#, Int#, Commits s #)+{-# noinline goString #-}+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.+-- TODO: The UTF-8 variant of this rule is unsound because GHC actually+-- used Modified UTF-8.+{-# RULES+"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# -> 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# -> 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++fromEffect ::+     Int -- ^ Maximum number of bytes the paste function needs+  -> (forall s. MutableByteArray s -> Int -> ST s Int)+     -- ^ Paste function. Takes a byte array and an offset and returns+     -- the new offset and having pasted into the buffer.+  -> Builder+{-# inline fromEffect #-}+fromEffect (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 #)++unST :: ST s a -> State# s -> (# State# s, a #)+unST (ST f) = f++shrinkMutableByteArray :: MutableByteArray s -> Int -> ST s ()+shrinkMutableByteArray (MutableByteArray arr) (I# sz) =+  primitive_ (Exts.shrinkMutableByteArray# arr sz)

@@ -0,0 +1,308 @@+{-# language BangPatterns #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language OverloadedStrings #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++import Control.Applicative (liftA2)+import Control.Monad.ST (runST)+import Data.Bytes.Builder+import Data.Bytes.Types (MutableBytes(MutableBytes))+import Data.Primitive (PrimArray)+import Data.Word+import Data.Char (ord,chr)+import Data.IORef (IORef,newIORef,readIORef,writeIORef)+import Data.Primitive (ByteArray)+import Data.WideWord (Word128(Word128),Word256(Word256))+import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.QuickCheck ((===),Arbitrary)+import Text.Printf (printf)+import Test.Tasty.HUnit ((@=?))++import qualified Arithmetic.Nat as Nat+import qualified Data.Bytes.Builder.Bounded as Bounded+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 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++tests :: TestTree+tests = testGroup "Tests"+  [ testGroup "live"+    [ TQC.testProperty "word64Dec" $ \w ->+        runConcat 1 (word64Dec w) === pack (show w)+    , TQC.testProperty "word64Dec-x3" $ \x y z ->+        runConcat 1 (word64Dec x <> word64Dec y <> word64Dec z)+        ===+        pack (show x ++ show y ++ show z)+    , TQC.testProperty "int64Dec-x3" $ \x y z ->+        runConcat 1 (int64Dec x <> int64Dec y <> int64Dec z)+        ===+        pack (show x ++ show y ++ show z)+    , TQC.testProperty "word64BE-x3" $ \x y 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 "word256PaddedLowerHex" $ \w ->+        Bounded.run Nat.constant (Bounded.word256PaddedLowerHex w)+        ===+        pack (showWord256PaddedLowerHex w)+    , TQC.testProperty "word128PaddedUpperHex" $ \w ->+        Bounded.run Nat.constant (Bounded.word128PaddedUpperHex w)+        ===+        pack (showWord128PaddedUpperHex w)+    , TQC.testProperty "word64PaddedUpperHex" $ \w ->+        runConcat 1 (word64PaddedUpperHex w)+        ===+        pack (showWord64PaddedUpperHex w)+    , TQC.testProperty "word16PaddedLowerHex" $ \w ->+        runConcat 1 (word16PaddedLowerHex w)+        ===+        pack (showWord16PaddedLowerHex w)+    , TQC.testProperty "wordPaddedDec2" $ TQC.forAll (TQC.choose (0,99)) $ \w ->+        Bounded.run Nat.two (Bounded.wordPaddedDec2 w)+        ===+        pack (zeroPadL 2 (show w))+    , TQC.testProperty "wordPaddedDec4" $ TQC.forAll (TQC.choose (0,9999)) $ \w ->+        Bounded.run Nat.constant (Bounded.wordPaddedDec4 w)+        ===+        pack (zeroPadL 4 (show w))+    , TQC.testProperty "wordPaddedDec9" $ TQC.forAll (TQC.choose (0,999999999)) $ \w ->+        Bounded.run Nat.constant (Bounded.wordPaddedDec9 w)+        ===+        pack (zeroPadL 9 (show w))+    , TQC.testProperty "word8Dec" $ \w ->+        runConcat 1 (word8Dec w)+        ===+        pack (show w)+    , TQC.testProperty "consLength32BE" $ \w ->+        runConcat 1 (consLength32BE (word8Dec w))+        ===+        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." @=?+          runConcat 1 (stringUtf8 "¿Cómo estás? I am doing well.")+    , THU.testCase "doubleDec-A" $+        pack (show (2 :: Int)) @=? runConcat 1 (doubleDec 2.0)+    , THU.testCase "doubleDec-B" $+        pack (show (2.5 :: Double)) @=? runConcat 1 (doubleDec 2.5)+    , THU.testCase "doubleDec-C" $+        pack ("1e+15") @=? runConcat 1 (doubleDec 1e15)+    , THU.testCase "doubleDec-D" $+        pack ("-42") @=? runConcat 1 (doubleDec (-42))+    , THU.testCase "doubleDec-E" $+        pack ("-8.88888888888888e+14") @=? runConcat 1 (doubleDec (-888888888888888.8888888))+    , THU.testCase "doubleDec-F" $+        pack ("42") @=? runConcat 1 (doubleDec 42)+    , THU.testCase "doubleDec-G" $+        pack ("0") @=? runConcat 1 (doubleDec 0)+    , THU.testCase "doubleDec-H" $+        pack ("0.5") @=? runConcat 1 (doubleDec 0.5)+    , THU.testCase "doubleDec-I" $+        pack ("-0.5") @=? runConcat 1 (doubleDec (-0.5))+    , THU.testCase "doubleDec-J" $+        pack ("999999999") @=? runConcat 1 (doubleDec 999999999)+    , THU.testCase "doubleDec-K" $+        pack ("-99999999") @=? runConcat 1 (doubleDec (-99999999))+    , THU.testCase "shortTextJsonString-A" $+        pack ("\"hello\"") @=? runConcat 1 (shortTextJsonString "hello")+    , THU.testCase "shortTextJsonString-B" $+        pack ("\"\\\\_\\\"_/\"") @=? runConcat 1 (shortTextJsonString "\\_\"_/")+    , THU.testCase "shortTextJsonString-C" $+        pack ("\"Hi\\r\\nLo\"") @=? runConcat 1 (shortTextJsonString "Hi\r\nLo")+    , THU.testCase "shortTextJsonString-D" $+        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))+    , TQC.testProperty "word128ArrayLE" $ \(xs :: [Word128]) ->+        let ys = Exts.fromList xs :: PrimArray Word128+         in runConcat 1 (foldMap word128LE xs)+            ===+            runConcat 1 (word128ArrayLE ys 0 (Prelude.length xs))+    , TQC.testProperty "word128ArrayBE" $ \(xs :: [Word128]) ->+        let ys = Exts.fromList xs :: PrimArray Word128+         in runConcat 1 (foldMap word128BE xs)+            ===+            runConcat 1 (word128ArrayBE ys 0 (Prelude.length xs))+    , TQC.testProperty "word256ArrayLE" $ \(xs :: [Word256]) ->+        let ys = Exts.fromList xs :: PrimArray Word256+         in runConcat 1 (foldMap word256LE xs)+            ===+            runConcat 1 (word256ArrayLE ys 0 (Prelude.length xs))+    , TQC.testProperty "word256ArrayBE" $ \(xs :: [Word256]) ->+        let ys = Exts.fromList xs :: PrimArray Word256+         in runConcat 1 (foldMap word256BE xs)+            ===+            runConcat 1 (word256ArrayBE ys 0 (Prelude.length xs))+    ]+  , testGroup "alternate"+    [ TQC.testProperty "HexWord64" $ \x y ->+        runConcat 1+          (  fromBounded Nat.constant (HexWord64.word64PaddedUpperHex x)+          <> fromBounded Nat.constant (HexWord64.word64PaddedUpperHex y)+          )+        ===+        pack (showWord64PaddedUpperHex x <> showWord64PaddedUpperHex y)+    ]+  , testGroup "putMany"+    [ THU.testCase "A" $ do+        ref <- newIORef []+        let txt = "hello_world_are_you_listening" :: [Char]+        putMany 7 ascii txt (bytesOntoRef ref)+        res <- readIORef ref+        id $+          [ map c2w "hello_"+          , map c2w "world_"+          , map c2w "are_yo"+          , map c2w "u_list"+          , map c2w "ening"+          ] @=? map Exts.toList (Exts.toList res)+    ]+  , testGroup "putManyConsLength"+    [ THU.testCase "A" $ do+        ref <- newIORef []+        let txt = "hello_world_are_you_listening" :: [Char]+        putManyConsLength Nat.constant+          (\n -> Bounded.word16BE (fromIntegral n))+          16 ascii txt (bytesOntoRef ref)+        res <- readIORef ref+        id $+          [ 0x00 : 0x0A : map c2w "hello_worl"+          , 0x00 : 0x0A : map c2w "d_are_you_"+          , 0x00 : 0x09 : map c2w "listening"+          ] @=? map Exts.toList (Exts.toList res)+    ]+  ]++bytesOntoRef ::+     IORef [PM.ByteArray]+  -> MutableBytes Exts.RealWorld+  -> IO ()+bytesOntoRef !ref (MutableBytes buf off len) = do+  rs <- readIORef ref+  dst <- PM.newByteArray len+  PM.copyMutableByteArray dst 0 buf off len+  dst' <- PM.unsafeFreezeByteArray dst+  writeIORef ref (rs ++ [dst'])++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++showWord256PaddedLowerHex :: Word256 -> String+showWord256PaddedLowerHex (Word256 hi mhi mlo lo) = printf "%016x%016x%016x%016x" hi mhi mlo lo++showWord128PaddedUpperHex :: Word128 -> String+showWord128PaddedUpperHex (Word128 hi lo) = printf "%016X%016X" hi lo++showWord64PaddedUpperHex :: Word64 -> String+showWord64PaddedUpperHex = printf "%016X"++showWord16PaddedLowerHex :: Word16 -> String+showWord16PaddedLowerHex = printf "%04x"++runConcat :: Int -> Builder -> ByteArray+runConcat n = Chunks.concatU . run n++c2w :: Char -> Word8+c2w = fromIntegral . ord++instance Arbitrary Word128 where+  arbitrary = liftA2 Word128 TQC.arbitrary TQC.arbitrary++instance Arbitrary Word256 where+  arbitrary = Word256 <$> TQC.arbitrary <*> TQC.arbitrary <*> TQC.arbitrary <*> TQC.arbitrary++zeroPadL :: Int -> String -> String+zeroPadL n s+  | length s < n = replicate (n - length s) '0' ++ s+  | otherwise = s