diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2019, Andrew Martin +Copyright (c) 2020, Andrew Martin All rights reserved. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Cell.hs b/bench/Cell.hs deleted file mode 100644 --- a/bench/Cell.hs +++ /dev/null @@ -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 ] - ] - diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -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 - diff --git a/bench/SimpleCsv.hs b/bench/SimpleCsv.hs deleted file mode 100644 --- a/bench/SimpleCsv.hs +++ /dev/null @@ -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 diff --git a/common/HexWord64.hs b/common/HexWord64.hs deleted file mode 100644 --- a/common/HexWord64.hs +++ /dev/null @@ -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 diff --git a/common/Word16Tree.hs b/common/Word16Tree.hs deleted file mode 100644 --- a/common/Word16Tree.hs +++ /dev/null @@ -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)) diff --git a/small-bytearray-builder.cabal b/small-bytearray-builder.cabal --- a/small-bytearray-builder.cabal +++ b/small-bytearray-builder.cabal @@ -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 diff --git a/src/Data/ByteArray/Builder.hs b/src/Data/ByteArray/Builder.hs deleted file mode 100644 --- a/src/Data/ByteArray/Builder.hs +++ /dev/null @@ -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\world ==> "hello\\u001Bworld"@ (where @\@ 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 diff --git a/src/Data/ByteArray/Builder/Bounded.hs b/src/Data/ByteArray/Builder/Bounded.hs deleted file mode 100644 --- a/src/Data/ByteArray/Builder/Bounded.hs +++ /dev/null @@ -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 diff --git a/src/Data/ByteArray/Builder/Bounded/Unsafe.hs b/src/Data/ByteArray/Builder/Bounded/Unsafe.hs deleted file mode 100644 --- a/src/Data/ByteArray/Builder/Bounded/Unsafe.hs +++ /dev/null @@ -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 - diff --git a/src/Data/ByteArray/Builder/Unsafe.hs b/src/Data/ByteArray/Builder/Unsafe.hs deleted file mode 100644 --- a/src/Data/ByteArray/Builder/Unsafe.hs +++ /dev/null @@ -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) diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -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