small-bytearray-builder 0.3.3.0 → 0.3.4.0
raw patch · 14 files changed
+15/−2984 lines, 14 filesdep +bytebuilddep −QuickCheckdep −bytestringdep −gaugedep ~basedep ~byteslicesetup-changed
Dependencies added: bytebuild
Dependencies removed: QuickCheck, bytestring, gauge, natural-arithmetic, primitive, primitive-checked, primitive-offset, primitive-unlifted, quickcheck-classes, run-st, small-bytearray-builder, tasty, tasty-hunit, tasty-quickcheck, text, text-short, vector, wide-word
Dependency ranges changed: base, byteslice
Files
- CHANGELOG.md +0/−76
- LICENSE +1/−1
- Setup.hs +0/−2
- bench/Cell.hs +0/−32
- bench/Main.hs +0/−80
- bench/SimpleCsv.hs +0/−31
- common/HexWord64.hs +0/−50
- common/Word16Tree.hs +0/−84
- small-bytearray-builder.cabal +14/−93
- src/Data/ByteArray/Builder.hs +0/−963
- src/Data/ByteArray/Builder/Bounded.hs +0/−971
- src/Data/ByteArray/Builder/Bounded/Unsafe.hs +0/−62
- src/Data/ByteArray/Builder/Unsafe.hs +0/−235
- test/Main.hs +0/−304
− CHANGELOG.md
@@ -1,76 +0,0 @@-# Revision history for small-bytearray-builder--## 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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2019, Andrew Martin+Copyright (c) 2020, Andrew Martin All rights reserved.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− bench/Cell.hs
@@ -1,32 +0,0 @@-{-# 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 ]- ]-
− bench/Main.hs
@@ -1,80 +0,0 @@-{-# language LambdaCase #-}-{-# language OverloadedStrings #-}--import Data.Primitive (ByteArray)-import Data.Word (Word64)-import Gauge (bgroup,bench,whnf)-import Gauge.Main (defaultMain)--import qualified Arithmetic.Nat as Nat-import qualified Data.ByteArray.Builder as B-import qualified Data.ByteArray.Builder.Bounded as U--import qualified Cell-import qualified SimpleCsv-import qualified HexWord64-import qualified Word16Tree--main :: IO ()-main = defaultMain- [ 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-
− bench/SimpleCsv.hs
@@ -1,31 +0,0 @@-{-# language LambdaCase #-}---- A variant of CSV encoding that does not perform--- any escaping or quoting. This is in its own module--- to make it easy to analyze the GHC Core that it--- gets compiled to.-module SimpleCsv- ( encodeRows- ) where--import Cell (Cell(..))-import Data.Primitive (SmallArray)--import qualified Data.Foldable as F-import qualified Data.ByteArray.Builder as B--encodeRows :: SmallArray (SmallArray Cell) -> B.Builder-encodeRows = F.foldr- (\r x -> encodeSimpleCsvRow r (B.ascii '\n' <> x))- mempty--encodeSimpleCsvRow :: SmallArray Cell -> B.Builder -> B.Builder-encodeSimpleCsvRow cs b = F.foldr- (\c x -> encodeSimpleCsvCell c <> B.ascii ',' <> x)- b- cs--encodeSimpleCsvCell :: Cell -> B.Builder-encodeSimpleCsvCell = \case- CellNumber n -> B.word32Dec n- CellString t -> B.shortTextUtf8 t
− common/HexWord64.hs
@@ -1,50 +0,0 @@-{-# 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.ByteArray.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
− common/Word16Tree.hs
@@ -1,84 +0,0 @@-{-# language BangPatterns #-}--module Word16Tree- ( Word16Tree- , encode- , exampleSmall- , example2000- , example9000- , expectedSmall- ) where--import Data.ByteArray.Builder as B-import Data.Word (Word16)-import Data.Primitive (ByteArray)-import qualified Data.Bytes as Bytes--data Word16Tree- = Branch !Word16Tree !Word16Tree- | Leaf {-# UNPACK #-} !Word16--encode :: Word16Tree -> Builder-encode (Leaf w) = B.word16PaddedUpperHex w-encode (Branch a b) =- B.ascii '('- <>- encode a- <>- B.ascii ','- <>- encode b- <>- B.ascii ')'--expectedSmall :: ByteArray-expectedSmall = Bytes.toByteArray $ Bytes.fromAsciiString- "((AB59,(1F33,2E71)),((((FA9A,247B),890C),(0F13,((55BF,7CF1),389B))),1205))"---exampleSmall :: Word16Tree-exampleSmall = Branch- (Branch- (Leaf 0xAB59)- (Branch- (Leaf 0x1F33)- (Leaf 0x2E71)- )- )- (Branch- (Branch - (Branch- (Branch- (Leaf 0xFA9A)- (Leaf 0x247B)- )- (Leaf 0x890C)- )- (Branch- (Leaf 0x0F13)- (Branch- (Branch- (Leaf 0x55BF)- (Leaf 0x7CF1)- )- (Leaf 0x389B)- )- )- )- (Leaf 0x1205)- )--example2000 :: Word16Tree-{-# noinline example2000 #-}-example2000 = balanced 0 2000--example9000 :: Word16Tree-{-# noinline example9000 #-}-example9000 = balanced 0 9000--balanced :: Word16 -> Word16 -> Word16Tree-balanced !off !n- | n == 0 = Leaf off- | n == 1 = Leaf (off + 1)- | otherwise = let x = div n 2 in- Branch (balanced off x) (balanced (off + x) (n - x))
small-bytearray-builder.cabal view
@@ -1,107 +1,28 @@ cabal-version: 2.2 name: small-bytearray-builder-version: 0.3.3.0-synopsis: Serialize to a small byte arrays+version: 0.3.4.0+synopsis: Serialize to bytes 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/small-bytearray-builder-bug-reports: https://github.com/byteverse/small-bytearray-builder/issues+ Compatibility shim for `bytebuild`. This reexports modules+ under then `Data.ByteArray` namespace.+homepage: https://github.com/byteverse/small-bytearray-builder-compat+bug-reports: https://github.com/byteverse/small-bytearray-builder-compat/issues license: BSD-3-Clause license-file: LICENSE author: Andrew Martin maintainer: andrew.thaddeus@gmail.com-copyright: 2019 Andrew Martin+copyright: 2020 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.ByteArray.Builder- Data.ByteArray.Builder.Unsafe- Data.ByteArray.Builder.Bounded- Data.ByteArray.Builder.Bounded.Unsafe reexported-modules:- Data.Bytes.Chunks+ , Data.Bytes.Chunks+ , Data.Bytes.Builder as Data.ByteArray.Builder+ , Data.Bytes.Builder.Unsafe as Data.ByteArray.Builder.Unsafe+ , Data.Bytes.Builder.Bounded as Data.ByteArray.Builder.Bounded+ , Data.Bytes.Builder.Bounded.Unsafe as Data.ByteArray.Builder.Bounded.Unsafe 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- , byteslice- , bytestring- , natural-arithmetic- , primitive- , primitive-unlifted >=0.1.2- , quickcheck-classes >=0.6.4- , small-bytearray-builder- , 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- , gauge >= 0.2.4- , natural-arithmetic- , primitive- , small-bytearray-builder- , text-short- , byteslice- ghc-options: -Wall -O2+ , byteslice >=0.2.2 && <0.2.3+ , bytebuild >=0.3.4 && <0.3.5 default-language: Haskell2010- hs-source-dirs: bench, common- main-is: Main.hs- other-modules:- Cell- HexWord64- SimpleCsv- Word16Tree
− src/Data/ByteArray/Builder.hs
@@ -1,963 +0,0 @@-{-# language BangPatterns #-}-{-# language DataKinds #-}-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language UnboxedTuples #-}--module Data.ByteArray.Builder- ( -- * Bounded Primitives- Builder- , fromBounded- -- * Evaluation- , run- , runOnto- , putMany- , putManyConsLength- -- * Materialized Byte Sequences- , bytes- , copy- , insert- , byteArray- , shortByteString- , shortTextUtf8- , shortTextJsonString- , cstring- , 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- , 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.ByteArray.Builder.Unsafe (Builder(Builder))-import Data.ByteArray.Builder.Unsafe (BuilderState(BuilderState),pasteIO)-import Data.ByteArray.Builder.Unsafe (Commits(Initial,Mutable,Immutable))-import Data.ByteArray.Builder.Unsafe (reverseCommitsOntoChunks)-import Data.ByteArray.Builder.Unsafe (stringUtf8,cstring)-import Data.ByteArray.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 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.ByteArray.Builder.Bounded as Bounded-import qualified Data.ByteArray.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---- | 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 "small-bytearray-builder: 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.-byteArray :: ByteArray -> Builder-byteArray a = bytes (Bytes a 0 (PM.sizeofByteArray a))---- | Create a builder from a short bytestring.-shortByteString :: ShortByteString -> Builder-shortByteString (SBS x) = bytes (Bytes a 0 (PM.sizeofByteArray a))- where a = ByteArray x---- | Create a builder from a sliced byte sequence. The variants--- 'copy' and 'insert' provide more control over whether or not--- the byte sequence is copied or aliased. This function is preferred--- when the user does not know the size of the byte sequence.-bytes :: Bytes -> Builder-bytes (Bytes (ByteArray src# ) (I# soff# ) (I# slen# )) = Builder- -- There are three cases to consider: (1) there is not enough- -- space and (1a) the chunk is not small or (1b) the chunk is- -- small; (2) There is enough space for a copy.- (\buf0 off0 len0 cs0 s0 -> case len0 <# slen# of- 1# -> case slen# >=# 256# of- 1# -> case Exts.newByteArray# 0# s0 of- (# s1, buf1 #) -> (# s1, buf1, 0#, 0#, Immutable src# soff# slen# (Mutable buf0 off0 cs0) #)- _ -> case Exts.newByteArray# 4080# s0 of- (# s1, buf1 #) -> case Exts.copyByteArray# src# soff# buf1 0# slen# s1 of- s2 -> (# s2, buf1, slen#, 4080# -# slen#, Mutable buf0 off0 cs0 #)- _ -> let !s1 = Exts.copyByteArray# src# soff# buf0 off0 slen# s0 in- (# s1, buf0, off0 +# slen#, len0 -# slen#, cs0 #)- )---- | Create a builder from a byte sequence. This always results in a--- call to @memcpy@. This is beneficial when the byte sequence is--- known to be small (less than 256 bytes).-copy :: Bytes -> Builder-copy (Bytes (ByteArray src# ) (I# soff# ) (I# slen# )) = Builder- (\buf0 off0 len0 cs0 s0 -> case len0 <# slen# of- 1# -> case Exts.newByteArray# newSz s0 of- (# s1, buf1 #) -> case Exts.copyByteArray# src# soff# buf1 0# slen# s1 of- s2 -> (# s2, buf1, slen#, newSz -# slen#, Mutable buf0 off0 cs0 #)- _ -> let !s1 = Exts.copyByteArray# src# soff# buf0 off0 slen# s0 in- (# s1, buf0, off0 +# slen#, len0 -# slen#, cs0 #)- )- where- !(I# newSz) = max (I# slen#) 4080---- | Create a builder from a byte sequence. This never calls @memcpy@.--- Instead, it pushes a chunk that references the argument byte sequence.--- This wastes the remaining space in the active chunk, so it may adversely--- affect performance if used carelessly. See 'flush' for a way to mitigate--- this problem. This functions is most beneficial when the byte sequence--- is known to be large (more than 8192 bytes).-insert :: Bytes -> Builder-insert (Bytes (ByteArray src# ) (I# soff# ) (I# slen# )) = Builder- (\buf0 off0 _ cs0 s0 -> case Exts.newByteArray# 0# s0 of- (# s1, buf1 #) ->- (# s1, buf1, 0#, 0#, Immutable src# soff# slen# (Mutable buf0 off0 cs0) #)- )---- | Create a builder from a slice of an array of 'Word8'. There is the same--- as 'bytes' but is provided as a convenience for users working with different--- types.-word8Array :: PrimArray Word8 -> Int -> Int -> Builder-word8Array (PrimArray arr) off len = bytes (Bytes (ByteArray arr) off len)--int64ArrayLE :: PrimArray Int64 -> Int -> Int -> Builder-int64ArrayLE (PrimArray x) = word64ArrayLE (PrimArray x)--int64ArrayBE :: PrimArray Int64 -> Int -> Int -> Builder-int64ArrayBE (PrimArray x) = word64ArrayBE (PrimArray x)--int32ArrayLE :: PrimArray Int32 -> Int -> Int -> Builder-int32ArrayLE (PrimArray x) = word32ArrayLE (PrimArray x)--int32ArrayBE :: PrimArray Int32 -> Int -> Int -> Builder-int32ArrayBE (PrimArray x) = word32ArrayBE (PrimArray x)--int16ArrayLE :: PrimArray Int16 -> Int -> Int -> Builder-int16ArrayLE (PrimArray x) = word16ArrayLE (PrimArray x)--int16ArrayBE :: PrimArray Int16 -> Int -> Int -> Builder-int16ArrayBE (PrimArray x) = word16ArrayBE (PrimArray x)--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 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
− src/Data/ByteArray/Builder/Bounded.hs
@@ -1,971 +0,0 @@-{-# 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.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- -- * 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- , char- -- ** Native- , wordPaddedDec2- , 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.ByteArray.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.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) =- -- 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 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 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
− src/Data/ByteArray/Builder/Bounded/Unsafe.hs
@@ -1,62 +0,0 @@-{-# 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 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-
− src/Data/ByteArray/Builder/Unsafe.hs
@@ -1,235 +0,0 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language UnboxedTuples #-}--module Data.ByteArray.Builder.Unsafe- ( -- * Types- Builder(..)- , BuilderState(..)- , Commits(..)- -- * Execution- , pasteST- , pasteIO- -- * Construction- , fromEffect- -- * Finalization- , reverseCommitsOntoChunks- , 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.ByteArray.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.ByteArray.Builder.Bounded as Bounded-import qualified Data.ByteArray.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 on 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---- | 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)
− test/Main.hs
@@ -1,304 +0,0 @@-{-# language BangPatterns #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}-{-# language OverloadedStrings #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--import Control.Applicative (liftA2)-import Control.Monad.ST (runST)-import Data.ByteArray.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.ByteArray.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 "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