small-bytearray-builder 0.1.1.0 → 0.2.0.0

raw patch · 11 files changed

+1221/−578 lines, 11 filesdep +natural-arithmeticdep +tasty-hunitdep +textdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: natural-arithmetic, tasty-hunit, text, text-short

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• bench/Main.hs +7/−5
• common/HexWord64.hs +1/−1
• small-bytearray-builder.cabal +16/−6
• src/Data/ByteArray/Builder.hs +405/−0
• src/Data/ByteArray/Builder/Bounded.hs +576/−0
• src/Data/ByteArray/Builder/Bounded/Unsafe.hs +59/−0
• src/Data/ByteArray/Builder/Small.hs +0/−250
• src/Data/ByteArray/Builder/Small/Unsafe.hs +0/−308
• src/Data/ByteArray/Builder/Unsafe.hs +94/−0
• test/Main.hs +50/−8

@@ -1,5 +1,18 @@ # Revision history for small-bytearray-builder +## 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.

@@ -1,9 +1,11 @@+import Data.Primitive (ByteArray)+import Data.Word (Word64) import Gauge (bgroup,bench,whnf) import Gauge.Main (defaultMain)-import Data.Word (Word64)-import Data.Primitive (ByteArray)-import qualified Data.ByteArray.Builder.Small.Unsafe as U +import qualified Arithmetic.Nat as Nat+import qualified Data.ByteArray.Builder.Bounded as U+ import qualified HexWord64  main :: IO ()@@ -33,7 +35,7 @@  encodeHexWord64s :: Word64s -> ByteArray {-# noinline encodeHexWord64s #-}-encodeHexWord64s (Word64s a b c d e f g h) = U.run $+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`@@ -45,7 +47,7 @@  encodeHexWord64sLoop :: Word64s -> ByteArray {-# noinline encodeHexWord64sLoop #-}-encodeHexWord64sLoop (Word64s a b c d e f g h) = U.run $+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`

@@ -17,7 +17,7 @@  import GHC.ST (ST(ST)) import Data.Bits-import Data.ByteArray.Builder.Small.Unsafe (Builder,construct)+import Data.ByteArray.Builder.Bounded.Unsafe (Builder,construct) import Data.Primitive import Data.Word import GHC.Exts

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: small-bytearray-builder-version: 0.1.1.0+version: 0.2.0.0 synopsis: Serialize to a small byte arrays description:   This is similar to the builder facilities provided by@@ -36,14 +36,19 @@  library   exposed-modules:-    Data.ByteArray.Builder.Small-    Data.ByteArray.Builder.Small.Unsafe+    Data.ByteArray.Builder+    Data.ByteArray.Builder.Unsafe+    Data.ByteArray.Builder.Bounded+    Data.ByteArray.Builder.Bounded.Unsafe   build-depends:     , base >=4.12.0.0 && <5     , byteslice >=0.1 && <0.2     , primitive-offset >=0.2 && <0.3     , run-st >=0.1 && <0.2     , vector >=0.12.0.3 && <0.13+    , bytestring >=0.10.8.2 && <0.11+    , text-short >=0.1.3 && <0.2+    , natural-arithmetic >=0.1 && <0.2   if flag(checked)     build-depends: primitive-checked >= 0.7 && <0.8   else@@ -57,17 +62,21 @@   type: exitcode-stdio-1.0   hs-source-dirs: test, common   main-is: Main.hs+  ghc-options: -O2 -Wall   other-modules:     HexWord64   build-depends:+    , QuickCheck >=2.13.1 && <2.14     , base >=4.12.0.0 && <5     , byteslice     , bytestring+    , natural-arithmetic+    , primitive     , small-bytearray-builder-    , QuickCheck >=2.13.1 && <2.14-    , tasty-quickcheck >=0.10.1 && <0.11     , tasty >=1.2.3 && <1.3-    , primitive+    , tasty-hunit >=0.10.0.2 && <0.11+    , tasty-quickcheck >=0.10.1 && <0.11+    , text >=1.2 && <1.3     , vector  benchmark bench@@ -75,6 +84,7 @@   build-depends:     , base     , gauge >= 0.2.4+    , natural-arithmetic     , primitive     , small-bytearray-builder   ghc-options: -Wall -O2

@@ -0,0 +1,405 @@+{-# language BangPatterns #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Data.ByteArray.Builder+  ( -- * Bounded Primitives+    Builder(..)+  , construct+  , fromBounded+    -- * Evaluation+  , run+  , pasteST+  , pasteIO+  , pasteGrowST+  , pasteGrowIO+  , pasteArrayST+  , pasteArrayIO+    -- * Materialized Byte Sequences+  , bytes+  , bytearray+  , shortTextUtf8+  , shortTextJsonString+  , cstring+  , stringUtf8+    -- * Encode Integral Types+    -- ** Human-Readable+  , word64Dec+  , word32Dec+  , word16Dec+  , word8Dec+  , wordDec+  , int64Dec+  , int32Dec+  , int16Dec+  , int8Dec+  , intDec+  , word64PaddedUpperHex+  , word32PaddedUpperHex+  , word16PaddedUpperHex+  , word8PaddedUpperHex+  , ascii+  , char+    -- ** Machine-Readable+  , word64BE+  , word32BE+  , word16BE+  , word8+    -- * Encode Floating-Point Types+    -- ** Human-Readable+  , doubleDec+  ) where++import Control.Monad.Primitive (primitive_)+import Control.Monad.ST (ST,stToIO)+import Control.Monad.ST.Run (runByteArrayST)+import Data.ByteArray.Builder.Unsafe (Builder(Builder))+import Data.ByteArray.Builder.Unsafe (stringUtf8,cstring)+import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.Bytes.Types (Bytes(Bytes),MutableBytes(MutableBytes))+import Data.Char (ord)+import Data.Int (Int64,Int32,Int16,Int8)+import Data.Primitive (ByteArray(..),MutableByteArray(..))+import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..))+import Data.Text.Short (ShortText)+import Data.Word (Word64,Word32,Word16,Word8)+import GHC.Exts (Int(I#),Char(C#),Int#,State#,ByteArray#,RealWorld,(>=#),(/=#))+import GHC.ST (ST(ST))++import qualified Arithmetic.Nat as Nat+import qualified Arithmetic.Types as Arithmetic+import qualified GHC.Exts as Exts+import qualified Data.Text.Short as TS+import qualified Data.Primitive as PM+import qualified Data.Vector as V+import qualified Data.ByteArray.Builder.Bounded as Bounded+import qualified Data.ByteArray.Builder.Bounded.Unsafe as UnsafeBounded++-- | Run a builder. An accurate size hint is important for good performance.+-- The size hint should be slightly larger than the actual size.+run ::+     Int -- ^ Hint for upper bound on size+  -> Builder -- ^ Builder+  -> ByteArray+run hint b = runByteArrayST $ do+  let go !n = do+        arr <- PM.newByteArray n+        pasteST b (MutableBytes arr 0 n) >>= \case+          Nothing -> go (n + 64)+          Just len -> do+            shrinkMutableByteArray arr len+            PM.unsafeFreezeByteArray arr+  go (max hint 1)++-- | Variant of 'pasteArrayST' that runs in 'IO'.+pasteArrayIO ::+     MutableBytes RealWorld -- ^ Buffer+  -> (a -> Builder) -- ^ Builder+  -> V.Vector a -- ^ Elements to serialize+  -> IO (V.Vector a, MutableBytes RealWorld) -- ^ Shifted vector, shifted buffer+pasteArrayIO !arr f !xs = stToIO (pasteArrayST arr f xs)++-- | Fold over a vector, applying the builder to each element until+-- the buffer cannot accomodate any more.+pasteArrayST ::+     MutableBytes s -- ^ Buffer+  -> (a -> Builder) -- ^ Builder+  -> V.Vector a -- ^ Elements to serialize+  -> ST s (V.Vector a, MutableBytes s) -- ^ Shifted vector, shifted buffer+pasteArrayST (MutableBytes arr off0 len0) f !xs0 = do+  let go !xs !ixBufA !lenBufA = if V.length xs > 0+        then do+          let a = V.unsafeHead xs+          pasteST (f a) (MutableBytes arr ixBufA lenBufA) >>= \case+            Nothing -> pure (xs,MutableBytes arr ixBufA lenBufA)+            Just ixBufB ->+              go (V.unsafeTail xs) ixBufB (lenBufA + (ixBufA - ixBufB))+        else pure (xs,MutableBytes arr ixBufA lenBufA)+  go xs0 off0 len0++-- | Paste the builder into the byte array starting at offset zero.+-- This repeatedly reallocates the byte array if it cannot accomodate+-- the builder, replaying the builder each time.+pasteGrowST ::+     Int -- ^ How many bytes to grow by at a time+  -> Builder+  -> MutableByteArrayOffset s+     -- ^ Initial buffer, used linearly. Do not reuse this argument.+  -> ST s (MutableByteArrayOffset s)+     -- ^ Final buffer that accomodated the builder.+pasteGrowST !n b !(MutableByteArrayOffset arr0 off0) = do+  let go !arr !sz = pasteST b (MutableBytes arr off0 (sz - off0)) >>= \case+        Nothing -> do+          let szNext = sz + n+          arrNext <- PM.resizeMutableByteArray arr szNext+          go arrNext szNext+        Just ix -> pure (MutableByteArrayOffset{array=arr,offset=ix})+  go arr0 =<< PM.getSizeofMutableByteArray arr0++-- | Variant of 'pasteGrowST' that runs in 'IO'.+pasteGrowIO ::+     Int -- ^ How many bytes to grow by at a time+  -> Builder+  -> MutableByteArrayOffset RealWorld+     -- ^ Initial buffer, used linearly. Do not reuse this argument.+  -> IO (MutableByteArrayOffset RealWorld)+     -- ^ Final buffer that accomodated the builder.+pasteGrowIO !n b !arr = stToIO (pasteGrowST n b arr)++-- | Execute the builder, pasting its contents into a buffer.+-- If the buffer is not large enough, this returns 'Nothing'.+-- Otherwise, it returns the index in the buffer that follows+-- the payload just written.+pasteST :: Builder -> MutableBytes s -> ST s (Maybe Int)+{-# inline pasteST #-}+pasteST (Builder f) (MutableBytes (MutableByteArray arr) (I# off) (I# len)) =+  ST $ \s0 -> case f arr off len s0 of+    (# s1, r #) -> if Exts.isTrue# (r /=# (-1#))+      then (# s1, Just (I# r) #)+      else (# s1, Nothing #)++-- | Variant of 'pasteST' that runs in 'IO'.+pasteIO :: Builder -> MutableBytes RealWorld -> IO (Maybe Int)+{-# inline pasteIO #-}+pasteIO b m = stToIO (pasteST b m)++-- | Constructor for 'Builder' that works on a function with lifted+-- arguments instead of unlifted ones. This is just as unsafe as the+-- actual constructor.+construct :: (forall s. MutableBytes s -> ST s (Maybe Int)) -> Builder+construct f = Builder+  $ \arr off len s0 ->+    case unST (f (MutableBytes (MutableByteArray arr) (I# off) (I# len))) s0 of+      (# s1, m #) -> case m of+        Nothing -> (# s1, (-1#) #)+        Just (I# n) -> (# s1, n #)++-- | 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 $ \arr off len s0 ->+  let !(I# req) = Nat.demote n in+  case len >=# req of+    1# -> f arr off s0+    _ -> (# s0, (-1#) #)++-- | Create a builder from an unsliced byte sequence.+bytearray :: ByteArray -> Builder+bytearray a = bytes (Bytes a 0 (PM.sizeofByteArray a))++-- | Create a builder from a sliced byte sequence.+bytes :: Bytes -> Builder+bytes (Bytes src soff slen) = construct $ \(MutableBytes arr off len) -> if len >= slen+  then do+    PM.copyByteArray arr off src soff slen+    pure (Just (off + slen))+  else pure Nothing++-- Internal function. Precondition, the referenced slice of the+-- byte sequence is UTF-8 encoded text.+slicedUtf8TextJson :: ByteArray# -> Int# -> Int# -> Builder+{-# inline slicedUtf8TextJson #-}+slicedUtf8TextJson !src# !soff0# !slen0# = construct $ \(MutableBytes dst doff0 dlen0) ->+  let slen0 = I# slen0#+   in if dlen0 > (2 * slen0) + 2+        then do+          PM.writeByteArray dst doff0 (c2w '"')+          let go !soff !slen !doff = if slen > 0+                then case indexChar8Array (ByteArray src#) soff of+                  '\\' -> write2 dst doff '\\' '\\' *> go (soff + 1) (slen - 1) (doff + 2)+                  '\"' -> write2 dst doff '\\' '\"' *> go (soff + 1) (slen - 1) (doff + 2)+                  '\n' -> write2 dst doff '\\' 'n' *> go (soff + 1) (slen - 1) (doff + 2)+                  '\r' -> write2 dst doff '\\' 'r' *> go (soff + 1) (slen - 1) (doff + 2)+                  '\t' -> write2 dst doff '\\' 't' *> go (soff + 1) (slen - 1) (doff + 2)+                  c -> if c >= '\x20'+                    then PM.writeByteArray dst doff (c2w c) *> go (soff + 1) (slen - 1) (doff + 1)+                    else do+                      write2 dst doff '\\' 'u'+                      doff' <- UnsafeBounded.pasteST+                        (Bounded.word16PaddedUpperHex (fromIntegral (c2w c)))+                        dst (doff + 2)+                      go (soff + 1) (slen - 1) doff'+                else pure doff+          doffRes <- go (I# soff0#) (I# slen0#) (doff0 + 1)+          PM.writeByteArray dst doffRes (c2w '"')+          pure (Just (doffRes + 1))+        else pure Nothing++-- 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"@+-- * @\_"_/ ==> "\\_\"_/"@+-- * @hello<ESC>world ==> "hello\u001Bworld"@ (where <LF> 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 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 = fromBounded Nat.constant (Bounded.char c)++-- | Encode an UTF8 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++shrinkMutableByteArray :: MutableByteArray s -> Int -> ST s ()+shrinkMutableByteArray (MutableByteArray arr) (I# sz) =+  primitive_ (Exts.shrinkMutableByteArray# arr sz)++-- | 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)++word8 :: Word8 -> Builder+word8 w = fromBounded Nat.constant (Bounded.word8 w)++-- 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,576 @@+{-# 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 in the amount of bytes they require.+module Data.ByteArray.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+  , word64PaddedUpperHex+  , word32PaddedUpperHex+  , word16PaddedUpperHex+  , word8PaddedUpperHex+  , ascii+  , char+    -- ** Machine-Readable+  , word64BE+  , word32BE+  , word16BE+  , word8+    -- * 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.ByteArray.Builder.Bounded.Unsafe (Builder(..))+import Data.Char (ord)+import Data.Primitive+import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..))+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.Types as Arithmetic+import qualified Arithmetic.Nat as Nat+import qualified Data.ByteArray.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) = wordCommonDec# 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++-- 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++-- | 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 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 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 :: Word16 -> Builder 4+word16PaddedUpperHex (W16# w) = word16PaddedUpperHex# 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++-- 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#++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#++-- 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#++-- 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#++-- | Encode an ASCII char.+-- Precondition: Input must be an ASCII character. This is not checked.+ascii :: Char -> Builder 1+ascii c = word8 (fromIntegral @Int @Word8 (ord c))++-- | 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)++    unsafeWordToWord8 :: Word -> Word8+    unsafeWordToWord8 (W# w) = W8# w++    -- 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++-- | 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 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 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

@@ -0,0 +1,59 @@+{-# language DataKinds #-}+{-# language GADTSyntax #-}+{-# language KindSignatures #-}+{-# language MagicHash #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Data.ByteArray.Builder.Bounded.Unsafe+  ( -- * Types+    Builder(..)+    -- * Construct+  , construct+    -- * Run+  , pasteST+  , pasteIO+  ) where++import GHC.TypeLits (Nat)+import Data.Kind (Type)+import GHC.IO (stToIO)+import GHC.ST (ST(ST))+import GHC.Exts (Int(I#),RealWorld,Int#,State#,MutableByteArray#)+import Data.Primitive (MutableByteArray(..))++-- | 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# #))+     -> 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+

@@ -1,250 +0,0 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language UnboxedTuples #-}--module Data.ByteArray.Builder.Small-  ( -- * Unsafe Primitives-    Builder(..)-  , construct-  , fromUnsafe-    -- * Evaluation-  , run-  , pasteST-  , pasteIO-  , pasteGrowST-  , pasteGrowIO-  , pasteArrayST-  , pasteArrayIO-    -- * Materialized Byte Sequences-  , bytes-  , bytearray-    -- * Encode Integral Types-    -- ** Human-Readable-  , word64Dec-  , int64Dec-  , word64PaddedUpperHex-  , word32PaddedUpperHex-  , word16PaddedUpperHex-  , word8PaddedUpperHex-    -- ** Machine-Readable-  , word64BE-  , word32BE-  , word16BE-  ) where--import Control.Monad.Primitive-import Control.Monad.ST-import Control.Monad.ST.Run (runByteArrayST)-import Data.Bytes.Types-import Data.Primitive-import Data.Int (Int64)-import GHC.Exts-import GHC.ST-import GHC.Word-import GHC.TypeLits (KnownNat,natVal')-import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..))--import qualified Data.Primitive as PM-import qualified Data.Vector as V-import qualified Data.ByteArray.Builder.Small.Unsafe as Unsafe---- | An unmaterialized sequence of bytes that may be pasted--- into a mutable byte array.-newtype Builder = Builder-  (forall s. MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #))--instance Semigroup Builder where-  {-# inline (<>) #-}-  Builder f <> Builder g = Builder $ \arr off0 len0 s0 -> case f arr off0 len0 s0 of-    (# s1, r #) -> case r /=# (-1#) of-      1# -> g arr r (len0 +# (off0 -# r)) s1-      _ -> (# s1, (-1#) #)--instance Monoid Builder where-  mempty = Builder $ \_ off0 _ s0 -> (# s0, off0 #)---- | Run a builder. An accurate size hint is important for good performance.--- The size hint should be slightly larger than the actual size.-run ::-     Int -- ^ Hint for upper bound on size-  -> Builder -- ^ Builder-  -> ByteArray-run hint b = runByteArrayST $ do-  let go !n = do-        arr <- newByteArray n-        pasteST b (MutableBytes arr 0 n) >>= \case-          Nothing -> go (n + 64)-          Just len -> do-            shrinkMutableByteArray arr len-            unsafeFreezeByteArray arr-  go hint---- | Variant of 'pasteArrayST' that runs in 'IO'.-pasteArrayIO ::-     MutableBytes RealWorld -- ^ Buffer-  -> (a -> Builder) -- ^ Builder-  -> V.Vector a -- ^ Elements to serialize-  -> IO (V.Vector a, MutableBytes RealWorld) -- ^ Shifted vector, shifted buffer-pasteArrayIO !arr f !xs = stToIO (pasteArrayST arr f xs)---- | Fold over a vector, applying the builder to each element until--- the buffer cannot accomodate any more.-pasteArrayST ::-     MutableBytes s -- ^ Buffer-  -> (a -> Builder) -- ^ Builder-  -> V.Vector a -- ^ Elements to serialize-  -> ST s (V.Vector a, MutableBytes s) -- ^ Shifted vector, shifted buffer-pasteArrayST (MutableBytes arr off0 len0) f !xs0 = do-  let go !xs !ixBufA !lenBufA = if V.length xs > 0-        then do-          let a = V.unsafeHead xs-          pasteST (f a) (MutableBytes arr ixBufA lenBufA) >>= \case-            Nothing -> pure (xs,MutableBytes arr ixBufA lenBufA)-            Just ixBufB ->-              go (V.unsafeTail xs) ixBufB (lenBufA + (ixBufA - ixBufB))-        else pure (xs,MutableBytes arr ixBufA lenBufA)-  go xs0 off0 len0---- | Paste the builder into the byte array starting at offset zero.--- This repeatedly reallocates the byte array if it cannot accomodate--- the builder, replaying the builder each time.-pasteGrowST ::-     Int -- ^ How many bytes to grow by at a time-  -> Builder-  -> MutableByteArray s-     -- ^ Initial buffer, used linearly. Do not reuse this argument.-  -> ST s (MutableByteArrayOffset s)-     -- ^ Final buffer that accomodated the builder.-pasteGrowST !n b !arr0 = do-  let go !arr !sz = pasteST b (MutableBytes arr 0 sz) >>= \case-        Nothing -> do-          let szNext = sz + n-          arrNext <- PM.newByteArray szNext-          go arrNext szNext-        Just ix -> pure (MutableByteArrayOffset{array=arr,offset=ix})-  go arr0 =<< PM.getSizeofMutableByteArray arr0---- | Variant of 'pasteGrowST' that runs in 'IO'.-pasteGrowIO ::-     Int -- ^ How many bytes to grow by at a time-  -> Builder-  -> MutableByteArray RealWorld-     -- ^ Initial buffer, used linearly. Do not reuse this argument.-  -> IO (MutableByteArrayOffset RealWorld)-     -- ^ Final buffer that accomodated the builder.-pasteGrowIO !n b !arr = stToIO (pasteGrowST n b arr)---- | Execute the builder, pasting its contents into a buffer.--- If the buffer is not large enough, this returns 'Nothing'.--- Otherwise, it returns the index in the buffer that follows--- the payload just written.-pasteST :: Builder -> MutableBytes s -> ST s (Maybe Int)-{-# inline pasteST #-}-pasteST (Builder f) (MutableBytes (MutableByteArray arr) (I# off) (I# len)) =-  ST $ \s0 -> case f arr off len s0 of-    (# s1, r #) -> if isTrue# (r /=# (-1#))-      then (# s1, Just (I# r) #)-      else (# s1, Nothing #)---- | Variant of 'pasteST' that runs in 'IO'.-pasteIO :: Builder -> MutableBytes RealWorld -> IO (Maybe Int)-{-# inline pasteIO #-}-pasteIO b m = stToIO (pasteST b m)---- | Constructor for 'Builder' that works on a function with lifted--- arguments instead of unlifted ones. This is just as unsafe as the--- actual constructor.-construct :: (forall s. MutableBytes s -> ST s (Maybe Int)) -> Builder-construct f = Builder-  $ \arr off len s0 ->-    case unST (f (MutableBytes (MutableByteArray arr) (I# off) (I# len))) s0 of-      (# s1, m #) -> case m of-        Nothing -> (# s1, (-1#) #)-        Just (I# n) -> (# s1, n #)--fromUnsafe :: forall n. KnownNat n => Unsafe.Builder n -> Builder-{-# inline fromUnsafe #-}-fromUnsafe (Unsafe.Builder f) = Builder $ \arr off len s0 ->-  case fromIntegral (natVal' (proxy# :: Proxy# n)) of-    I# req -> case len >=# req of-      1# -> f arr off s0-      _ -> (# s0, (-1#) #)---- | Create a builder from an unsliced byte sequence.-bytearray :: ByteArray -> Builder-bytearray a = bytes (Bytes a 0 (sizeofByteArray a))---- | Create a builder from a sliced byte sequence.-bytes :: Bytes -> Builder-bytes (Bytes src soff slen) = construct $ \(MutableBytes arr off len) -> if len >= slen-  then do-    copyByteArray arr off src soff slen-    pure (Just (len - slen))-  else pure Nothing---- | 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 = fromUnsafe (Unsafe.word64Dec 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 = fromUnsafe (Unsafe.int64Dec 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 =-  fromUnsafe (Unsafe.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 =-  fromUnsafe (Unsafe.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 =-  fromUnsafe (Unsafe.word16PaddedUpperHex 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 =-  fromUnsafe (Unsafe.word8PaddedUpperHex w)--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_ (shrinkMutableByteArray# arr sz)---- | Requires exactly 8 bytes. Dump the octets of a 64-bit--- word in a big-endian fashion.-word64BE :: Word64 -> Builder-word64BE w = fromUnsafe (Unsafe.word64BE w)---- | Requires exactly 4 bytes. Dump the octets of a 32-bit--- word in a big-endian fashion.-word32BE :: Word32 -> Builder-word32BE w = fromUnsafe (Unsafe.word32BE w)---- | Requires exactly 2 bytes. Dump the octets of a 16-bit--- word in a big-endian fashion.-word16BE :: Word16 -> Builder-word16BE w = fromUnsafe (Unsafe.word16BE w)

@@ -1,308 +0,0 @@-{-# language GADTSyntax #-}-{-# language KindSignatures #-}-{-# language ScopedTypeVariables #-}-{-# language BangPatterns #-}-{-# language MagicHash #-}-{-# language UnboxedTuples #-}-{-# language RankNTypes #-}-{-# language LambdaCase #-}-{-# language TypeOperators #-}-{-# language DataKinds #-}-{-# language TypeApplications #-}---- | The functions in this module do not check to--- see if there is enough space in the buffer.-module Data.ByteArray.Builder.Small.Unsafe-  ( -- * Builder-    Builder(..)-  , construct-    -- * Execute-  , run-  , pasteST-  , pasteIO-    -- * Combine-  , append-    -- * Encode Integral Types-    -- ** Human-Readable-  , word64Dec-  , int64Dec-  , word64PaddedUpperHex-  , word32PaddedUpperHex-  , word16PaddedUpperHex-  , word8PaddedUpperHex-    -- ** Machine-Readable-  , word64BE-  , word32BE-  , word16BE-  ) where--import Control.Monad.Primitive-import Control.Monad.ST-import Data.Bits-import Data.Char (ord)-import Data.Primitive-import GHC.Exts-import GHC.ST-import GHC.Word-import GHC.Int-import Data.Kind-import GHC.TypeLits (KnownNat,Nat,type (+),natVal')---- | 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# #))-     -> Builder n---- | Execute the builder. This function is safe.-run :: forall n. KnownNat n-  => Builder n -- ^ Builder-  -> ByteArray-{-# inline run #-}-run b = runST $ do-  arr <- newByteArray (fromIntegral (natVal' (proxy# :: Proxy# n)))-  len <- pasteST b arr 0-  shrinkMutableByteArray arr len-  unsafeFreezeByteArray arr---- | 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)---- | 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 #)--infixr 9 `append`---- | Concatenate two builders.-append :: Builder n -> Builder m -> Builder (n + m)-append (Builder f) (Builder g) =-  Builder $ \arr off0 s0 -> case f arr off0 s0 of-    (# s1, r #) -> g arr r s1---- | 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) = word64Dec# 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) = int64Dec# w---- | Requires up to 19 bytes.-word64Dec# :: Word# -> Builder 19-{-# noinline word64Dec# #-}-word64Dec# w# = 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 19 bytes.-int64Dec# :: Int# -> Builder 20-{-# noinline int64Dec# #-}-int64Dec# w# = 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---- | 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 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 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 :: Word16 -> Builder 4-word16PaddedUpperHex (W16# w) = word16PaddedUpperHex# 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---- 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# = 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#--word32PaddedUpperHex# :: Word# -> Builder 8-{-# noinline word32PaddedUpperHex# #-}-word32PaddedUpperHex# w# = 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#---- 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# = 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#---- Definitely want this to inline. It's maybe a dozen instructions total.-word8PaddedUpperHex# :: Word# -> Builder 2-{-# inline word8PaddedUpperHex #-}-word8PaddedUpperHex# w# = 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#---- | Requires exactly 8 bytes. Dump the octets of a 64-bit--- word in a big-endian fashion.-word64BE :: Word64 -> Builder 8-word64BE w = 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 big-endian fashion.-word32BE :: Word32 -> Builder 4-word32BE w = 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 big-endian fashion.-word16BE :: Word16 -> Builder 2-word16BE w = construct $ \arr off -> do-  writeByteArray arr (off    ) (fromIntegral @Word16 @Word8 (unsafeShiftR w 8))-  writeByteArray arr (off + 1) (fromIntegral @Word16 @Word8 w)-  pure (off + 2)---- 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--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_ (shrinkMutableByteArray# arr sz)

@@ -0,0 +1,94 @@+{-# language BangPatterns #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Data.ByteArray.Builder.Unsafe+  ( -- * Types+    Builder(..)+    -- * Safe Functions+    -- | These functions are actually completely safe, but they are defined+    -- here because they are used by typeclass instances. Import them from+    -- @Data.ByteArray.Builder@ instead.+  , stringUtf8+  , cstring+  ) where++import Data.Primitive (MutableByteArray(MutableByteArray))+import Foreign.C.String (CString)+import GHC.Exts ((-#),(+#),(/=#),(>#))+import GHC.Exts (Addr#,Int(I#),Ptr(Ptr))+import GHC.Exts (IsString,Int#,State#,MutableByteArray#)+import GHC.ST (ST(ST))+import GHC.Base (unpackCString#,unpackCStringUtf8#)++import qualified GHC.Exts as Exts+import qualified Data.ByteArray.Builder.Bounded as Bounded+import qualified Data.ByteArray.Builder.Bounded.Unsafe as UnsafeBounded++-- | An unmaterialized sequence of bytes that may be pasted+-- into a mutable byte array.+newtype Builder = Builder+  -- This functions takes an offset and a number of remaining bytes+  -- and returns the new offset.+  (forall s. MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #))++instance IsString Builder where+  {-# inline fromString #-}+  fromString = stringUtf8++instance Semigroup Builder where+  {-# inline (<>) #-}+  Builder f <> Builder g = Builder $ \arr off0 len0 s0 -> case f arr off0 len0 s0 of+    (# s1, r #) -> case r /=# (-1#) of+      1# -> g arr r (len0 +# (off0 -# r)) s1+      _ -> (# s1, (-1#) #)++instance Monoid Builder where+  {-# inline mempty #-}+  mempty = Builder $ \_ off0 _ s0 -> (# s0, off0 #)++-- | Create a builder from a cons-list of 'Char'. These+-- are be UTF-8 encoded.+stringUtf8 :: String -> Builder+{-# inline stringUtf8 #-}+stringUtf8 cs = Builder (\arr off0 len0 s0 -> goString cs arr off0 len0 s0)++-- | Create a builder from a @NUL@-terminated 'CString'. This ignores any+-- textual encoding, copying bytes until @NUL@ is reached.+cstring :: CString -> Builder+{-# inline cstring #-}+cstring (Ptr cs) = Builder (\arr off0 len0 s0 -> goCString cs arr off0 len0 s0)++goString :: String -> MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+{-# noinline goString #-}+goString [] _ off0 _ s0 = (# s0, off0 #)+goString (c : cs) buf off0 len0 s0 = case len0 ># 3# of+  1# -> case unST (UnsafeBounded.pasteST (Bounded.char c) (MutableByteArray buf) (I# off0)) s0 of+    (# s1, I# off1 #) -> goString cs buf off1 (len0 -# (off1 -# off0)) s1+  _ -> (# s0, (-1#) #)++-- We have to have a rule for both unpackCString# and unpackCStringUtf8#+-- since GHC uses a different function based on whether or not non-ASCII+-- codepoints are used in the string.+{-# RULES+"Builder stringUtf8/cstring" forall s a b c d.+  goString (unpackCString# s) a b c d = goCString s a b c d+"Builder stringUtf8/cstring-utf8" forall s a b c d.+  goString (unpackCStringUtf8# s) a b c d = goCString s a b c d+#-}++goCString :: Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+goCString addr buf off0 len0 s0 = case Exts.indexWord8OffAddr# addr 0# of+  0## -> (# s0, off0 #)+  w -> case len0 of+    0# -> (# s0, (-1#) #)+    _ -> case Exts.writeWord8Array# buf off0 w s0 of+      s1 -> goCString (Exts.plusAddr# addr 1# ) buf (off0 +# 1# ) (len0 -# 1# ) s1++unST :: ST s a -> State# s -> (# State# s, a #)+unST (ST f) = f+

@@ -1,25 +1,31 @@ {-# language BangPatterns #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-}+{-# language OverloadedStrings #-}  import Control.Monad.ST (runST) import Data.Bytes.Types (MutableBytes(..))-import Data.ByteArray.Builder.Small+import Data.ByteArray.Builder import Data.Word import Data.Char (ord) import Data.Primitive (ByteArray)-import Debug.Trace import Test.Tasty (defaultMain,testGroup,TestTree) import Test.QuickCheck ((===)) import Text.Printf (printf)+import Test.Tasty.HUnit ((@=?))++import qualified Arithmetic.Nat as Nat+import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as BB-import qualified Data.Primitive as PM+import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.List as L+import qualified Data.Primitive as PM+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import qualified Data.Vector as V-import qualified Test.Tasty.QuickCheck as TQC-import qualified Test.QuickCheck as QC import qualified GHC.Exts as Exts-import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Test.Tasty.HUnit as THU+import qualified Test.Tasty.QuickCheck as TQC  import qualified HexWord64 @@ -51,12 +57,45 @@         (runArray word64Dec (V.fromList xs))         ===         pack (foldMap show xs)+    , THU.testCase "stringUtf8" $+        packUtf8 "¿Cómo estás? I am doing well." @=?+          run 1 (stringUtf8 "¿Cómo estás? I am doing well.")+    , THU.testCase "doubleDec-A" $+        pack (show (2 :: Int)) @=? run 1 (doubleDec 2.0)+    , THU.testCase "doubleDec-B" $+        pack (show (2.5 :: Double)) @=? run 1 (doubleDec 2.5)+    , THU.testCase "doubleDec-C" $+        pack ("1e+15") @=? run 1 (doubleDec 1e15)+    , THU.testCase "doubleDec-D" $+        pack ("-42") @=? run 1 (doubleDec (-42))+    , THU.testCase "doubleDec-E" $+        pack ("-8.88888888888888e+14") @=? run 1 (doubleDec (-888888888888888.8888888))+    , THU.testCase "doubleDec-F" $+        pack ("42") @=? run 1 (doubleDec 42)+    , THU.testCase "doubleDec-G" $+        pack ("0") @=? run 1 (doubleDec 0)+    , THU.testCase "doubleDec-H" $+        pack ("0.5") @=? run 1 (doubleDec 0.5)+    , THU.testCase "doubleDec-I" $+        pack ("-0.5") @=? run 1 (doubleDec (-0.5))+    , THU.testCase "doubleDec-J" $+        pack ("999999999") @=? run 1 (doubleDec 999999999)+    , THU.testCase "doubleDec-K" $+        pack ("-99999999") @=? run 1 (doubleDec (-99999999))+    , THU.testCase "shortTextJsonString-A" $+        pack ("\"hello\"") @=? run 1 (shortTextJsonString "hello")+    , THU.testCase "shortTextJsonString-B" $+        pack ("\"\\\\_\\\"_/\"") @=? run 1 (shortTextJsonString "\\_\"_/")+    , THU.testCase "shortTextJsonString-C" $+        pack ("\"Hi\\r\\nLo\"") @=? run 1 (shortTextJsonString "Hi\r\nLo")+    , THU.testCase "shortTextJsonString-D" $+        pack ("\"Hi\\u001BLo\"") @=? run 1 (shortTextJsonString "Hi\ESCLo")     ]   , testGroup "alternate"     [ TQC.testProperty "HexWord64" $ \x y ->         run 1-          (  fromUnsafe (HexWord64.word64PaddedUpperHex x)-          <> fromUnsafe (HexWord64.word64PaddedUpperHex y)+          (  fromBounded Nat.constant (HexWord64.word64PaddedUpperHex x)+          <> fromBounded Nat.constant (HexWord64.word64PaddedUpperHex y)           )         ===         pack (showWord64PaddedUpperHex x <> showWord64PaddedUpperHex y)@@ -65,6 +104,9 @@  pack :: String -> ByteArray pack = Exts.fromList . map (fromIntegral @Int @Word8 . ord)++packUtf8 :: String -> ByteArray+packUtf8 = Exts.fromList . ByteString.unpack . TE.encodeUtf8 . T.pack  -- This is used to test pasteArrayST runArray ::