diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,36 +1,36 @@
-## 0.2.5
-
-* Supported GHC 9.2.1
-
-## 0.2.4
-
-* Generalised the argument `intersperse`, `unlines`, `unwords` from a list to any `Foldable`
-* Supported GHC 9.0.1
-
-## 0.2.3
-
-* Added `intDecPadded`
-* Exported backend types: `StrictByteStringBackend`, `LazyByteStringBackend` and `BufferedIOBackend`
-
-## 0.2.2
-
-* Added `withPopper` and `toStreamingBody`
-* Added `viaShow`
-* Added `intersperse`, `unwords` and `unlines`
-* Optmised the internal representation
-
-## 0.2.1
-
-* Added `Mason.Builder.Compat`
-
-## 0.2
-
-* Added `doubleFixed`, `doubleSI` and `doubleExp`
-* Added `textUtf8`
-* Added `prefixVarInt`, `wordVLQ` and `intVLQ`
-* Renamed `padded` and `zeroPadded` to `paddedBoundedPrim` and `zeroPaddedBoundedPrim` respectively
-* Added `Mason.Builder.Dynamic`
-
-## 0 -- 2019-12-05
-
-* First version. Released on an unsuspecting world.
+## 0.2.5
+
+* Supported GHC 9.2.1
+
+## 0.2.4
+
+* Generalised the argument `intersperse`, `unlines`, `unwords` from a list to any `Foldable`
+* Supported GHC 9.0.1
+
+## 0.2.3
+
+* Added `intDecPadded`
+* Exported backend types: `StrictByteStringBackend`, `LazyByteStringBackend` and `BufferedIOBackend`
+
+## 0.2.2
+
+* Added `withPopper` and `toStreamingBody`
+* Added `viaShow`
+* Added `intersperse`, `unwords` and `unlines`
+* Optmised the internal representation
+
+## 0.2.1
+
+* Added `Mason.Builder.Compat`
+
+## 0.2
+
+* Added `doubleFixed`, `doubleSI` and `doubleExp`
+* Added `textUtf8`
+* Added `prefixVarInt`, `wordVLQ` and `intVLQ`
+* Renamed `padded` and `zeroPadded` to `paddedBoundedPrim` and `zeroPaddedBoundedPrim` respectively
+* Added `Mason.Builder.Dynamic`
+
+## 0 -- 2019-12-05
+
+* First version. Released on an unsuspecting world.
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,194 +1,194 @@
-mason: alacritous builder library
-====
-
-[](https://travis-ci.com/fumieval/mason)
-[](https://hackage.haskell.org/package/mason)
-
-mason is a builder & IO library.
-
-* __Fast__: much faster than bytestring's Builder.
-* __Extensible__: Builders can be consumed in a user-defined way.
-* __Hackable__: Low-level APIs are exposed. It's easy to plug in even pointer-level operations.
-
-`Mason.Builder` has API mostly compatible with `Data.ByteString.Builder` but there are some additions to the original API:
-
-* `toStrictByteString` produces a strict `ByteString` directly.
-* `hPutBuilderLen` writes a builder to a handle and returns the number of bytes.
-* `sendBuilder` sends the content of `Builder` over a socket.
-* `withPopper` turns a builder into http-client's[GivesPopper](http://hackage.haskell.org/package/http-client-0.7.2.1/docs/Network-HTTP-Client.html#t:GivesPopper)
-* `toStreamingBody` creates wai's [StreamingBody](http://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:StreamingBody)
-
-Usage
-----
-
-Replace `Data.ByteString.Builder` with `Mason.Builder`. Note that if you have `Builder` in the type signature, you'll need `RankNTypes` extensions because of the design explained below. Alternatively, you can also import `Mason.Builder.Compat` which has an API almost compatible with `Data.ByteString.Builder`.
-
-Performance
-----
-
-As long as the code is optimised, mason's builder can be very fast (twice or more as bytestring). Make sure that functions returning `Builder`s are well inlined.
-
-Serialisation of JSON-like structure:
-
-```
-mason/hPutBuilder mean 274.7 μs ( +- 49.40 μs )
-fast-builder/hPutBuilder mean 399.9 μs ( +- 76.05 μs )
-bytestring/hPutBuilder mean 335.1 μs ( +- 86.96 μs )
-mason/toStrictByteString mean 106.6 μs ( +- 6.680 μs )
-fast-builder/toStrictByteString mean 254.8 μs ( +- 31.64 μs )
-bytestring/toLazyByteString mean 283.3 μs ( +- 24.26 μs )
-mason/toLazyByteString mean 127.2 μs ( +- 25.86 μs )
-fast-builder/toLazyByteString mean 249.0 μs ( +- 25.60 μs )
-bytestring/toLazyByteString mean 263.4 μs ( +- 9.401 μs )
-```
-
-In the same benchmark application, the allocation footprint of mason is feathery.
-
-```
-toStrictByteString
-mason 291,112 0
-fast-builder 991,016 0
-bytestring 1,158,584 0 (toStrict . toLazyByteString)
-
-toLazyByteString
-Case Allocated GCs
-mason 228,936 0
-fast-builder 903,752 0
-bytestring 1,101,448 0
-```
-
-`doubleDec` employs Grisu3 which grants ~20x speedup over `show`-based implementation.
-
-```
-mason/double mean 116.2 ns ( +- 6.654 ns )
-fast-builder/double mean 2.183 μs ( +- 85.80 ns )
-bytestring/double mean 2.312 μs ( +- 118.8 ns )
-```
-
-You can find more benchmarks below:
-
-* [bytes-builder-shootout](https://github.com/andrewthad/bytes-builder-shootout)
-
-
-Click to expand
-
-treeToHex-2000/small-bytearray-builder mean 44.01 μs ( +- 1.620 μs )
-treeToHex-2000/fast-builder mean 34.40 μs ( +- 390.1 ns )
-treeToHex-2000/bytestring mean 58.76 μs ( +- 3.843 μs )
-treeToHex-2000/mason mean 41.08 μs ( +- 180.8 ns )
-treeToHex-9000/small-bytearray-builder mean 191.8 μs ( +- 1.835 μs )
-treeToHex-9000/bytestring mean 284.8 μs ( +- 1.156 μs )
-treeToHex-9000/mason mean 181.2 μs ( +- 386.3 ns )
-short-text-tree-1000/small-bytearray-builder mean 26.54 μs ( +- 34.08 ns )
-short-text-tree-1000/fast-builder mean 37.51 μs ( +- 99.85 ns )
-short-text-tree-1000/bytestring mean 37.95 μs ( +- 167.5 ns )
-short-text-tree-1000/mason mean 26.87 μs ( +- 312.4 ns )
-byte-tree-2000/small-bytearray-builder mean 30.53 μs ( +- 51.53 ns )
-byte-tree-2000/fast-builder mean 26.91 μs ( +- 592.2 ns )
-byte-tree-2000/bytestring mean 54.40 μs ( +- 1.743 μs )
-byte-tree-2000/mason mean 34.34 μs ( +- 193.5 ns )
-
-
-
-* [haskell-perf/strict-bytestring-builder](https://github.com/haskell-perf/strict-bytestring-builders)
-
-
-Click to expand
-
-averagedAppends-1/byteStringStrictBuilder mean 116.3 ns ( +- 6.479 ns )
-averagedAppends-1/byteStringTreeBuilder mean 181.7 ns ( +- 20.88 ns )
-averagedAppends-1/fastBuilder mean 181.5 ns ( +- 7.219 ns )
-averagedAppends-1/bufferBuilder mean 728.5 ns ( +- 9.114 ns )
-averagedAppends-1/byteString mean 358.7 ns ( +- 4.663 ns )
-averagedAppends-1/blazeBuilder mean 356.0 ns ( +- 7.604 ns )
-averagedAppends-1/binary mean 635.0 ns ( +- 7.936 ns )
-averagedAppends-1/cereal mean 638.6 ns ( +- 12.40 ns )
-averagedAppends-1/mason mean 155.2 ns ( +- 2.000 ns )
-averagedAppends-100/byteStringStrictBuilder mean 7.290 μs ( +- 99.74 ns )
-averagedAppends-100/byteStringTreeBuilder mean 13.40 μs ( +- 283.4 ns )
-averagedAppends-100/fastBuilder mean 13.07 μs ( +- 418.2 ns )
-averagedAppends-100/bufferBuilder mean 19.57 μs ( +- 5.644 μs )
-averagedAppends-100/byteString mean 17.31 μs ( +- 1.609 μs )
-averagedAppends-100/blazeBuilder mean 19.15 μs ( +- 6.533 μs )
-averagedAppends-100/binary mean 48.26 μs ( +- 727.1 ns )
-averagedAppends-100/cereal mean 51.57 μs ( +- 21.81 μs )
-averagedAppends-100/mason mean 12.07 μs ( +- 233.8 ns )
-averagedAppends-10000/byteStringStrictBuilder mean 1.038 ms ( +- 18.63 μs )
-averagedAppends-10000/byteStringTreeBuilder mean 1.989 ms ( +- 70.63 μs )
-averagedAppends-10000/fastBuilder mean 1.611 ms ( +- 42.24 μs )
-averagedAppends-10000/bufferBuilder mean 1.895 ms ( +- 25.09 μs )
-averagedAppends-10000/byteString mean 2.248 ms ( +- 40.99 μs )
-averagedAppends-10000/blazeBuilder mean 2.394 ms ( +- 1.016 ms )
-averagedAppends-10000/binary mean 6.503 ms ( +- 157.6 μs )
-averagedAppends-10000/cereal mean 6.458 ms ( +- 221.6 μs )
-averagedAppends-10000/mason mean 1.738 ms ( +- 25.89 μs )
-regularConcat-100/byteStringStrictBuilder mean 1.606 μs ( +- 32.93 ns )
-regularConcat-100/byteStringTreeBuilder mean 2.000 μs ( +- 43.73 ns )
-regularConcat-100/fastBuilder mean 1.364 μs ( +- 37.95 ns )
-regularConcat-100/bufferBuilder mean 2.204 μs ( +- 48.40 ns )
-regularConcat-100/byteString mean 1.253 μs ( +- 25.68 ns )
-regularConcat-100/blazeBuilder mean 1.317 μs ( +- 24.05 ns )
-regularConcat-100/binary mean 2.845 μs ( +- 62.24 ns )
-regularConcat-100/cereal mean 3.021 μs ( +- 48.53 ns )
-regularConcat-100/mason mean 1.405 μs ( +- 35.11 ns )
-regularConcat-10000/byteStringStrictBuilder mean 321.3 μs ( +- 11.13 μs )
-regularConcat-10000/byteStringTreeBuilder mean 349.1 μs ( +- 4.359 μs )
-regularConcat-10000/fastBuilder mean 121.0 μs ( +- 1.755 μs )
-regularConcat-10000/bufferBuilder mean 156.1 μs ( +- 2.050 μs )
-regularConcat-10000/byteString mean 106.6 μs ( +- 1.355 μs )
-regularConcat-10000/blazeBuilder mean 110.8 μs ( +- 1.397 μs )
-regularConcat-10000/binary mean 308.1 μs ( +- 5.346 μs )
-regularConcat-10000/cereal mean 352.0 μs ( +- 6.142 μs )
-regularConcat-10000/mason mean 130.2 μs ( +- 10.39 μs )
-
-
-
-Architecture
-----
-
-Mason's builder is a function that takes a purpose-dependent environment and a buffer. There is little intermediate structure involved; almost everything runs in one pass. This design is inspired by [fast-builder](http://hackage.haskell.org/package/fast-builder).
-
-```haskell
-type Builder = forall s. Buildable s => BuilderFor s
-
-newtype BuilderFor s = Builder { unBuilder :: s -> Buffer -> IO Buffer }
-
-data Buffer = Buffer
- { bEnd :: {-# UNPACK #-} !(Ptr Word8) -- ^ end of the buffer (next to the last byte)
- , bCur :: {-# UNPACK #-} !(Ptr Word8) -- ^ current position
- }
-
-class Buildable s where
- byteString :: B.ByteString -> BuilderFor s
- flush :: BuilderFor s
- allocate :: Int -> BuilderFor s
-```
-
-Instances of the `Buildable` class implement purpose-specific behaviour (e.g. exponentially allocate a buffer, flush to disk). This generic interface also allows creative uses of Builders such as on-the-fly compression.
-
-`Builder` has a smart constructor called `ensure`:
-
-```haskell
-ensure :: Int -> (Buffer -> IO Buffer) -> Builder
-```
-
-`ensure n f` secures at least `n` bytes in the buffer and passes the pointer to `f`. This gives rise to monoid homorphism; namely, `ensure m f <> ensure n g` will fuse into `ensure (m + n) (f >=> g)` so don't worry about the overhead of bound checking.
-
-Creating your own primitives
-----
-
-The easiest way to create a new primitive is `withPtr`, a simplified version of `ensure`. This is quite convenient for calling foreign functions or anything low-level.
-
-```haskell
--- | Construct a 'Builder' from a "poke" function.
-withPtr :: Int -- ^ number of bytes to allocate (if needed)
- -> (Ptr Word8 -> IO (Ptr Word8)) -- ^ return a next pointer after writing
- -> Builder
-
-grisu v = withPtr 24 $ \ptr -> do
- n <- dtoa_grisu3 v ptr
- return $ plusPtr ptr (fromIntegral n)
-
-foreign import ccall unsafe "static dtoa_grisu3"
- dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt
-```
+mason: alacritous builder library
+====
+
+[](https://travis-ci.com/fumieval/mason)
+[](https://hackage.haskell.org/package/mason)
+
+mason is a builder & IO library.
+
+* __Fast__: much faster than bytestring's Builder.
+* __Extensible__: Builders can be consumed in a user-defined way.
+* __Hackable__: Low-level APIs are exposed. It's easy to plug in even pointer-level operations.
+
+`Mason.Builder` has API mostly compatible with `Data.ByteString.Builder` but there are some additions to the original API:
+
+* `toStrictByteString` produces a strict `ByteString` directly.
+* `hPutBuilderLen` writes a builder to a handle and returns the number of bytes.
+* `sendBuilder` sends the content of `Builder` over a socket.
+* `withPopper` turns a builder into http-client's[GivesPopper](http://hackage.haskell.org/package/http-client-0.7.2.1/docs/Network-HTTP-Client.html#t:GivesPopper)
+* `toStreamingBody` creates wai's [StreamingBody](http://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:StreamingBody)
+
+Usage
+----
+
+Replace `Data.ByteString.Builder` with `Mason.Builder`. Note that if you have `Builder` in the type signature, you'll need `RankNTypes` extensions because of the design explained below. Alternatively, you can also import `Mason.Builder.Compat` which has an API almost compatible with `Data.ByteString.Builder`.
+
+Performance
+----
+
+As long as the code is optimised, mason's builder can be very fast (twice or more as bytestring). Make sure that functions returning `Builder`s are well inlined.
+
+Serialisation of JSON-like structure:
+
+```
+mason/hPutBuilder mean 274.7 μs ( +- 49.40 μs )
+fast-builder/hPutBuilder mean 399.9 μs ( +- 76.05 μs )
+bytestring/hPutBuilder mean 335.1 μs ( +- 86.96 μs )
+mason/toStrictByteString mean 106.6 μs ( +- 6.680 μs )
+fast-builder/toStrictByteString mean 254.8 μs ( +- 31.64 μs )
+bytestring/toLazyByteString mean 283.3 μs ( +- 24.26 μs )
+mason/toLazyByteString mean 127.2 μs ( +- 25.86 μs )
+fast-builder/toLazyByteString mean 249.0 μs ( +- 25.60 μs )
+bytestring/toLazyByteString mean 263.4 μs ( +- 9.401 μs )
+```
+
+In the same benchmark application, the allocation footprint of mason is feathery.
+
+```
+toStrictByteString
+mason 291,112 0
+fast-builder 991,016 0
+bytestring 1,158,584 0 (toStrict . toLazyByteString)
+
+toLazyByteString
+Case Allocated GCs
+mason 228,936 0
+fast-builder 903,752 0
+bytestring 1,101,448 0
+```
+
+`doubleDec` employs Grisu3 which grants ~20x speedup over `show`-based implementation.
+
+```
+mason/double mean 116.2 ns ( +- 6.654 ns )
+fast-builder/double mean 2.183 μs ( +- 85.80 ns )
+bytestring/double mean 2.312 μs ( +- 118.8 ns )
+```
+
+You can find more benchmarks below:
+
+* [bytes-builder-shootout](https://github.com/andrewthad/bytes-builder-shootout)
+
+
+Click to expand
+
+treeToHex-2000/small-bytearray-builder mean 44.01 μs ( +- 1.620 μs )
+treeToHex-2000/fast-builder mean 34.40 μs ( +- 390.1 ns )
+treeToHex-2000/bytestring mean 58.76 μs ( +- 3.843 μs )
+treeToHex-2000/mason mean 41.08 μs ( +- 180.8 ns )
+treeToHex-9000/small-bytearray-builder mean 191.8 μs ( +- 1.835 μs )
+treeToHex-9000/bytestring mean 284.8 μs ( +- 1.156 μs )
+treeToHex-9000/mason mean 181.2 μs ( +- 386.3 ns )
+short-text-tree-1000/small-bytearray-builder mean 26.54 μs ( +- 34.08 ns )
+short-text-tree-1000/fast-builder mean 37.51 μs ( +- 99.85 ns )
+short-text-tree-1000/bytestring mean 37.95 μs ( +- 167.5 ns )
+short-text-tree-1000/mason mean 26.87 μs ( +- 312.4 ns )
+byte-tree-2000/small-bytearray-builder mean 30.53 μs ( +- 51.53 ns )
+byte-tree-2000/fast-builder mean 26.91 μs ( +- 592.2 ns )
+byte-tree-2000/bytestring mean 54.40 μs ( +- 1.743 μs )
+byte-tree-2000/mason mean 34.34 μs ( +- 193.5 ns )
+
+
+
+* [haskell-perf/strict-bytestring-builder](https://github.com/haskell-perf/strict-bytestring-builders)
+
+
+Click to expand
+
+averagedAppends-1/byteStringStrictBuilder mean 116.3 ns ( +- 6.479 ns )
+averagedAppends-1/byteStringTreeBuilder mean 181.7 ns ( +- 20.88 ns )
+averagedAppends-1/fastBuilder mean 181.5 ns ( +- 7.219 ns )
+averagedAppends-1/bufferBuilder mean 728.5 ns ( +- 9.114 ns )
+averagedAppends-1/byteString mean 358.7 ns ( +- 4.663 ns )
+averagedAppends-1/blazeBuilder mean 356.0 ns ( +- 7.604 ns )
+averagedAppends-1/binary mean 635.0 ns ( +- 7.936 ns )
+averagedAppends-1/cereal mean 638.6 ns ( +- 12.40 ns )
+averagedAppends-1/mason mean 155.2 ns ( +- 2.000 ns )
+averagedAppends-100/byteStringStrictBuilder mean 7.290 μs ( +- 99.74 ns )
+averagedAppends-100/byteStringTreeBuilder mean 13.40 μs ( +- 283.4 ns )
+averagedAppends-100/fastBuilder mean 13.07 μs ( +- 418.2 ns )
+averagedAppends-100/bufferBuilder mean 19.57 μs ( +- 5.644 μs )
+averagedAppends-100/byteString mean 17.31 μs ( +- 1.609 μs )
+averagedAppends-100/blazeBuilder mean 19.15 μs ( +- 6.533 μs )
+averagedAppends-100/binary mean 48.26 μs ( +- 727.1 ns )
+averagedAppends-100/cereal mean 51.57 μs ( +- 21.81 μs )
+averagedAppends-100/mason mean 12.07 μs ( +- 233.8 ns )
+averagedAppends-10000/byteStringStrictBuilder mean 1.038 ms ( +- 18.63 μs )
+averagedAppends-10000/byteStringTreeBuilder mean 1.989 ms ( +- 70.63 μs )
+averagedAppends-10000/fastBuilder mean 1.611 ms ( +- 42.24 μs )
+averagedAppends-10000/bufferBuilder mean 1.895 ms ( +- 25.09 μs )
+averagedAppends-10000/byteString mean 2.248 ms ( +- 40.99 μs )
+averagedAppends-10000/blazeBuilder mean 2.394 ms ( +- 1.016 ms )
+averagedAppends-10000/binary mean 6.503 ms ( +- 157.6 μs )
+averagedAppends-10000/cereal mean 6.458 ms ( +- 221.6 μs )
+averagedAppends-10000/mason mean 1.738 ms ( +- 25.89 μs )
+regularConcat-100/byteStringStrictBuilder mean 1.606 μs ( +- 32.93 ns )
+regularConcat-100/byteStringTreeBuilder mean 2.000 μs ( +- 43.73 ns )
+regularConcat-100/fastBuilder mean 1.364 μs ( +- 37.95 ns )
+regularConcat-100/bufferBuilder mean 2.204 μs ( +- 48.40 ns )
+regularConcat-100/byteString mean 1.253 μs ( +- 25.68 ns )
+regularConcat-100/blazeBuilder mean 1.317 μs ( +- 24.05 ns )
+regularConcat-100/binary mean 2.845 μs ( +- 62.24 ns )
+regularConcat-100/cereal mean 3.021 μs ( +- 48.53 ns )
+regularConcat-100/mason mean 1.405 μs ( +- 35.11 ns )
+regularConcat-10000/byteStringStrictBuilder mean 321.3 μs ( +- 11.13 μs )
+regularConcat-10000/byteStringTreeBuilder mean 349.1 μs ( +- 4.359 μs )
+regularConcat-10000/fastBuilder mean 121.0 μs ( +- 1.755 μs )
+regularConcat-10000/bufferBuilder mean 156.1 μs ( +- 2.050 μs )
+regularConcat-10000/byteString mean 106.6 μs ( +- 1.355 μs )
+regularConcat-10000/blazeBuilder mean 110.8 μs ( +- 1.397 μs )
+regularConcat-10000/binary mean 308.1 μs ( +- 5.346 μs )
+regularConcat-10000/cereal mean 352.0 μs ( +- 6.142 μs )
+regularConcat-10000/mason mean 130.2 μs ( +- 10.39 μs )
+
+
+
+Architecture
+----
+
+Mason's builder is a function that takes a purpose-dependent environment and a buffer. There is little intermediate structure involved; almost everything runs in one pass. This design is inspired by [fast-builder](http://hackage.haskell.org/package/fast-builder).
+
+```haskell
+type Builder = forall s. Buildable s => BuilderFor s
+
+newtype BuilderFor s = Builder { unBuilder :: s -> Buffer -> IO Buffer }
+
+data Buffer = Buffer
+ { bEnd :: {-# UNPACK #-} !(Ptr Word8) -- ^ end of the buffer (next to the last byte)
+ , bCur :: {-# UNPACK #-} !(Ptr Word8) -- ^ current position
+ }
+
+class Buildable s where
+ byteString :: B.ByteString -> BuilderFor s
+ flush :: BuilderFor s
+ allocate :: Int -> BuilderFor s
+```
+
+Instances of the `Buildable` class implement purpose-specific behaviour (e.g. exponentially allocate a buffer, flush to disk). This generic interface also allows creative uses of Builders such as on-the-fly compression.
+
+`Builder` has a smart constructor called `ensure`:
+
+```haskell
+ensure :: Int -> (Buffer -> IO Buffer) -> Builder
+```
+
+`ensure n f` secures at least `n` bytes in the buffer and passes the pointer to `f`. This gives rise to monoid homorphism; namely, `ensure m f <> ensure n g` will fuse into `ensure (m + n) (f >=> g)` so don't worry about the overhead of bound checking.
+
+Creating your own primitives
+----
+
+The easiest way to create a new primitive is `withPtr`, a simplified version of `ensure`. This is quite convenient for calling foreign functions or anything low-level.
+
+```haskell
+-- | Construct a 'Builder' from a "poke" function.
+withPtr :: Int -- ^ number of bytes to allocate (if needed)
+ -> (Ptr Word8 -> IO (Ptr Word8)) -- ^ return a next pointer after writing
+ -> Builder
+
+grisu v = withPtr 24 $ \ptr -> do
+ n <- dtoa_grisu3 v ptr
+ return $ plusPtr ptr (fromIntegral n)
+
+foreign import ccall unsafe "static dtoa_grisu3"
+ dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt
+```
diff --git a/mason.cabal b/mason.cabal
--- a/mason.cabal
+++ b/mason.cabal
@@ -1,39 +1,39 @@
-cabal-version: 2.4
-
-name: mason
-version: 0.2.5
-synopsis: Fast and extensible bytestring builder
-description:
- This package provides efficient implementation of bytestring builders.
- See README.md for details
-bug-reports: https://github.com/fumieval/mason/issues
-license: BSD-3-Clause
-license-file: LICENSE
-author: Fumiaki Kinoshita
-maintainer: fumiexcel@gmail.com
-copyright: 2021 Fumiaki Kinoshita, Don Stewart 2005-2009, Duncan Coutts 2006-2015, David Roundy 2003-2005, Jasper Van der Jeugt 2010, Simon Meier 2010-2013, Ben Gamari 2017
-category: Data
-extra-source-files: CHANGELOG.md, README.md
-tested-with: GHC == 9.2.1, GHC==9.0.1, GHC==8.10.7
-
-source-repository head
- type: git
- location: https://github.com/fumieval/mason.git
-
-library
- exposed-modules:
- Mason.Builder
- Mason.Builder.Internal
- Mason.Builder.Dynamic
- Mason.Builder.Compat
-
- c-sources: cbits/dtoa.c
- ghc-options: -Wall -O2
- build-depends: base >= 4.12.0.0 && <5
- , bytestring
- , text
- , network >= 2.7 && <3.2
- , ghc-prim
- , array
- hs-source-dirs: src
- default-language: Haskell2010
+cabal-version: 2.4
+
+name: mason
+version: 0.2.6
+synopsis: Fast and extensible bytestring builder
+description:
+ This package provides efficient implementation of bytestring builders.
+ See README.md for details
+bug-reports: https://github.com/fumieval/mason/issues
+license: BSD-3-Clause
+license-file: LICENSE
+author: Fumiaki Kinoshita
+maintainer: fumiexcel@gmail.com
+copyright: 2021 Fumiaki Kinoshita, Don Stewart 2005-2009, Duncan Coutts 2006-2015, David Roundy 2003-2005, Jasper Van der Jeugt 2010, Simon Meier 2010-2013, Ben Gamari 2017
+category: Data
+extra-source-files: CHANGELOG.md, README.md
+tested-with: GHC == 9.4.2, GHC == 9.2.5, GHC==9.0.1, GHC==8.10.7
+
+source-repository head
+ type: git
+ location: https://github.com/fumieval/mason.git
+
+library
+ exposed-modules:
+ Mason.Builder
+ Mason.Builder.Internal
+ Mason.Builder.Dynamic
+ Mason.Builder.Compat
+
+ c-sources: cbits/dtoa.c
+ ghc-options: -Wall -O2
+ build-depends: base >= 4.12.0.0 && <5
+ , bytestring
+ , text
+ , network >= 2.7 && <3.2
+ , ghc-prim
+ , array
+ hs-source-dirs: src
+ default-language: Haskell2010
diff --git a/src/Mason/Builder.hs b/src/Mason/Builder.hs
--- a/src/Mason/Builder.hs
+++ b/src/Mason/Builder.hs
@@ -1,761 +1,761 @@
-{-# LANGUAGE MagicHash, CPP, UnboxedTuples #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
--- |
--- Module : Mason.Builder
--- Copyright : (c) Fumiaki Kinoshita 2019-
--- License : BSD3
---
--- Maintainer : Fumiaki Kinoshita
---
-----------------------------------------------------------------------------
-module Mason.Builder
- ( Builder
- , BuilderFor
- , Buildable
- -- * Runners
- , StrictByteStringBackend
- , toStrictByteString
- , LazyByteStringBackend
- , toLazyByteString
- , BufferedIOBackend
- , hPutBuilderLen
- , hPutBuilder
- , sendBuilder
- , withPopper
- , StreamingBackend
- , toStreamingBody
- -- * Primitives
- , flush
- -- * Bytes
- , byteString
- , lazyByteString
- , shortByteString
- -- * Text
- , textUtf8
- , encodeUtf8Builder
- , encodeUtf8BuilderEscaped
- , char7
- , string7
- , char8
- , string8
- , charUtf8
- , stringUtf8
- -- * Primitive
- , storable
- , int8
- , word8
- , int16LE
- , int32LE
- , int64LE
- , word16LE
- , word32LE
- , word64LE
- , floatLE
- , doubleLE
- , int16BE
- , int32BE
- , int64BE
- , word16BE
- , word32BE
- , word64BE
- , floatBE
- , doubleBE
- -- * Numeral
- , floatDec
- , doubleDec
- , doubleSI
- , doubleExp
- , doubleFixed
- , word8Dec
- , word16Dec
- , word32Dec
- , word64Dec
- , wordDec
- , int8Dec
- , int16Dec
- , int32Dec
- , int64Dec
- , intDec
- , intDecPadded
- , integerDec
- , word8Hex
- , word16Hex
- , word32Hex
- , word64Hex
- , wordHex
- , int8HexFixed
- , int16HexFixed
- , int32HexFixed
- , int64HexFixed
- , word8HexFixed
- , word16HexFixed
- , word32HexFixed
- , word64HexFixed
- , floatHexFixed
- , doubleHexFixed
- , byteStringHex
- , lazyByteStringHex
- -- * Variable-length encoding
- , intVLQ
- , intVLQBP
- , wordVLQ
- , wordVLQBP
- , prefixVarInt
- , prefixVarIntBP
- -- * Combinators
- , intersperse
- , Mason.Builder.unwords
- , Mason.Builder.unlines
- , viaShow
- -- * Advanced
- , paddedBoundedPrim
- , zeroPaddedBoundedPrim
- , primFixed
- , primBounded
- , lengthPrefixedWithin
-
- ) where
-
-import Control.Monad
-import qualified Data.Array as A
-import Data.Bits
-import Data.Foldable (toList)
-import Data.Word
-import Data.Int
-import qualified Data.Text as T
-import Foreign.C.Types
-import Foreign.Ptr (Ptr, plusPtr, castPtr)
-import Foreign.Storable
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Internal as B
-import qualified Data.ByteString.Lazy as BL
-import Mason.Builder.Internal as B
-import qualified Data.ByteString.Builder.Prim as P
-import qualified Data.ByteString.Builder.Prim.Internal as P
-#if !MIN_VERSION_bytestring(0,10,12)
-import Data.ByteString.Builder.Prim (boudedPrim)
-#endif
-import System.IO (Handle)
-
--- | Put the content of a 'Builder' to a 'Handle'.
-hPutBuilder :: Handle -> BuilderFor PutEnv -> IO ()
-hPutBuilder h b = void $ hPutBuilderLen h b
-{-# INLINE hPutBuilder #-}
-
--- | Combine chunks of a lazy 'BL.ByteString'
-lazyByteString :: BL.ByteString -> Builder
-lazyByteString x = foldMap byteString (BL.toChunks x)
-{-# INLINE lazyByteString #-}
-
-------------------------------------------------------------------------------
--- Binary encodings
-------------------------------------------------------------------------------
-
--- | Encode a single signed byte as-is.
---
-{-# INLINE int8 #-}
-int8 :: Int8 -> Builder
-int8 x = B.primFixed P.int8 x
-
--- | Encode a single unsigned byte as-is.
---
-{-# INLINE word8 #-}
-word8 :: Word8 -> Builder
-word8 x = B.primFixed P.word8 x
-
-
-------------------------------------------------------------------------------
--- Binary little-endian encodings
-------------------------------------------------------------------------------
-
--- | Encode an 'Int16' in little endian format.
-{-# INLINE int16LE #-}
-int16LE :: Int16 -> Builder
-int16LE x = B.primFixed P.int16LE x
-
--- | Encode an 'Int32' in little endian format.
-{-# INLINE int32LE #-}
-int32LE :: Int32 -> Builder
-int32LE x = B.primFixed P.int32LE x
-
--- | Encode an 'Int64' in little endian format.
-{-# INLINE int64LE #-}
-int64LE :: Int64 -> Builder
-int64LE x = B.primFixed P.int64LE x
-
--- | Encode a 'Word16' in little endian format.
-{-# INLINE word16LE #-}
-word16LE :: Word16 -> Builder
-word16LE x = B.primFixed P.word16LE x
-
--- | Encode a 'Word32' in little endian format.
-{-# INLINE word32LE #-}
-word32LE :: Word32 -> Builder
-word32LE x = B.primFixed P.word32LE x
-
--- | Encode a 'Word64' in little endian format.
-{-# INLINE word64LE #-}
-word64LE :: Word64 -> Builder
-word64LE x = B.primFixed P.word64LE x
-
--- | Encode a 'Float' in little endian format.
-{-# INLINE floatLE #-}
-floatLE :: Float -> Builder
-floatLE x = B.primFixed P.floatLE x
-
--- | Encode a 'Double' in little endian format.
-{-# INLINE doubleLE #-}
-doubleLE :: Double -> Builder
-doubleLE x = B.primFixed P.doubleLE x
-
-
-------------------------------------------------------------------------------
--- Binary big-endian encodings
-------------------------------------------------------------------------------
-
--- | Encode an 'Int16' in big endian format.
-{-# INLINE int16BE #-}
-int16BE :: Int16 -> Builder
-int16BE x = B.primFixed P.int16BE x
-
--- | Encode an 'Int32' in big endian format.
-{-# INLINE int32BE #-}
-int32BE :: Int32 -> Builder
-int32BE x = B.primFixed P.int32BE x
-
--- | Encode an 'Int64' in big endian format.
-{-# INLINE int64BE #-}
-int64BE :: Int64 -> Builder
-int64BE x = B.primFixed P.int64BE x
-
--- | Encode a 'Word16' in big endian format.
-{-# INLINE word16BE #-}
-word16BE :: Word16 -> Builder
-word16BE x = B.primFixed P.word16BE x
-
--- | Encode a 'Word32' in big endian format.
-{-# INLINE word32BE #-}
-word32BE :: Word32 -> Builder
-word32BE x = B.primFixed P.word32BE x
-
--- | Encode a 'Word64' in big endian format.
-{-# INLINE word64BE #-}
-word64BE :: Word64 -> Builder
-word64BE x = B.primFixed P.word64BE x
-
--- | Encode a 'Float' in big endian format.
-{-# INLINE floatBE #-}
-floatBE :: Float -> Builder
-floatBE x = B.primFixed P.floatBE x
-
--- | Encode a 'Double' in big endian format.
-{-# INLINE doubleBE #-}
-doubleBE :: Double -> Builder
-doubleBE x = B.primFixed P.doubleBE x
-
-------------------------------------------------------------------------------
--- ASCII encoding
-------------------------------------------------------------------------------
-
--- | Char7 encode a 'Char'.
-{-# INLINE char7 #-}
-char7 :: Char -> Builder
-char7 x = B.primFixed P.char7 x
-
--- | Char7 encode a 'String'.
-{-# INLINE string7 #-}
-string7 :: String -> Builder
-string7 x = B.primMapListFixed P.char7 x
-
-------------------------------------------------------------------------------
--- ISO/IEC 8859-1 encoding
-------------------------------------------------------------------------------
-
--- | Char8 encode a 'Char'.
-{-# INLINE char8 #-}
-char8 :: Char -> Builder
-char8 x = B.primFixed P.char8 x
-
--- | Char8 encode a 'String'.
-{-# INLINE string8 #-}
-string8 :: String -> Builder
-string8 x = B.primMapListFixed P.char8 x
-
-------------------------------------------------------------------------------
--- UTF-8 encoding
-------------------------------------------------------------------------------
-
--- | UTF-8 encode a 'Char'.
-{-# INLINE charUtf8 #-}
-charUtf8 :: Char -> Builder
-charUtf8 x = B.primBounded P.charUtf8 x
-
--- | Encode 'T.Text' as a UTF-8 byte stream. Synonym for 'textUtf8'.
-encodeUtf8Builder :: T.Text -> Builder
-encodeUtf8Builder x = textUtf8 x
-{-# INLINE encodeUtf8Builder #-}
-
--- | Encode 'T.Text' as a UTF-8 byte stream.
-textUtf8 :: T.Text -> Builder
-textUtf8 x = B.encodeUtf8BuilderEscaped (P.liftFixedToBounded P.word8) x
-{-# INLINE textUtf8 #-}
-
---------------------
--- Unsigned integers
---------------------
-
--- | Decimal encoding of a 'Word8' using the ASCII digits.
-{-# INLINE word8Dec #-}
-word8Dec :: Word8 -> Builder
-word8Dec x = B.primBounded P.word8Dec x
-
--- | Decimal encoding of a 'Word16' using the ASCII digits.
-{-# INLINE word16Dec #-}
-word16Dec :: Word16 -> Builder
-word16Dec x = B.primBounded P.word16Dec x
-
--- | Decimal encoding of a 'Word32' using the ASCII digits.
-{-# INLINE word32Dec #-}
-word32Dec :: Word32 -> Builder
-word32Dec x = B.primBounded P.word32Dec x
-
--- | Decimal encoding of a 'Word64' using the ASCII digits.
-{-# INLINE word64Dec #-}
-word64Dec :: Word64 -> Builder
-word64Dec x = B.primBounded P.word64Dec x
-
--- | Decimal encoding of a 'Word' using the ASCII digits.
-{-# INLINE wordDec #-}
-wordDec :: Word -> Builder
-wordDec x = B.primBounded P.wordDec x
-
--- Floating point numbers
--------------------------
-
--- | /Currently slow./ Decimal encoding of an IEEE 'Float'.
-{-# INLINE floatDec #-}
-floatDec :: Float -> Builder
-floatDec x = string7 (show x)
-
-wrapDoubleDec :: Double -> (Double -> Builder) -> Builder
-wrapDoubleDec x k
- | isNaN x = string7 "NaN"
- | isInfinite x = if x < 0 then string7 "-Infinity" else string7 "Infinity"
- | isNegativeZero x = char7 '-' <> k 0.0
- | x < 0 = char7 '-' <> k (-x)
- | otherwise = k x
-{-# INLINE wrapDoubleDec #-}
-
--- | Decimal encoding of an IEEE 'Double'.
-{-# INLINE doubleDec #-}
-doubleDec :: Double -> Builder
-doubleDec val = wrapDoubleDec val $ \case
- 0 -> string7 "0.0"
- x -> grisu x
- where
- grisu v = withPtr 24 $ \ptr -> do
- n <- dtoa_grisu3 v ptr
- return $ plusPtr ptr (fromIntegral n)
-
-foreign import ccall unsafe "static dtoa_grisu3"
- dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt
-
--- | Attach an SI prefix so that abs(mantissa) is within [1, 1000). Omits c, d, da and h.
-doubleSI :: Int -- ^ precision: must be equal or greater than 3
- -> Double
- -> Builder
-doubleSI prec _ | prec < 3 = error "Mason.Builder.doubleSI: precision less than 3"
-doubleSI prec val = wrapDoubleDec val $ \case
- 0 -> zeroes prec
- val' -> Builder $ \env buf -> withGrisu3Rounded prec val' $ \ptr len e -> do
- let (pindex, dp) = divMod (e - 1) 3
- print (dp, prec, len)
- let mantissa
- -- when the decimal separator would be at the end
- | dp + 1 == prec = withPtr (prec + dp - 2) $ \dst -> do
- _ <- B.memset dst 48 $ fromIntegral (prec + dp - 2)
- B.memcpy dst ptr $ min len prec
- return $ dst `plusPtr` (prec + dp - 2)
- | otherwise = withPtr (prec + 1) $ \dst -> do
- _ <- B.memset dst 48 $ fromIntegral (prec + 1)
- B.memcpy dst ptr $ min len $ dp + 1
- pokeElemOff dst (dp + 1) 46
- B.memcpy (dst `plusPtr` (dp + 2)) (ptr `plusPtr` (dp + 1)) $ max 0 $ len - dp - 1
- return $ dst `plusPtr` (prec + 1)
- let prefix
- | pindex == 0 = mempty
- | pindex > 8 || pindex < (-8) = char7 'e' <> intDec (3 * pindex)
- | otherwise = charUtf8 (prefices A.! pindex)
- unBuilder (mantissa <> prefix) env buf
- where
- prefices = A.listArray (-8,8) "yzafpnμm\NULkMGTPEZY"
-
-zeroes :: Int -> Builder
-zeroes n = withPtr (n + 1) $ \dst -> do
- _ <- B.memset dst 48 $ fromIntegral $ n + 1
- pokeElemOff dst 1 46
- return $ dst `plusPtr` (n + 1)
-
--- | Always use exponents
-doubleExp :: Int -- ^ number of digits in the mantissa
- -> Double
- -> Builder
-doubleExp prec _ | prec < 1 = error "Mason.Builder.doubleFixed: precision too small"
-doubleExp prec val = wrapDoubleDec val $ \case
- 0 -> zeroes prec <> string7 "e0"
- val' -> Builder $ \env buf -> withGrisu3Rounded prec val' $ \ptr len dp -> do
- let len' = 1 + prec
-
- firstDigit <- peek ptr
-
- unBuilder (withPtr len' (\dst -> do
- _ <- B.memset dst 48 $ fromIntegral len'
- poke dst firstDigit
- poke (dst `plusPtr` 1) (46 :: Word8)
- B.memcpy (dst `plusPtr` 2) (ptr `plusPtr` 1) (min (len - 1) len')
- return (dst `plusPtr` len'))
- <> char7 'e' <> intDec (dp - 1)) env buf
-
--- | Fixed precision
-doubleFixed :: Int -- ^ decimal points
- -> Double
- -> Builder
-doubleFixed 0 val = intDec (round val)
-doubleFixed prec _ | prec < 0 = error "Mason.Builder.doubleFixed: negative precision"
-doubleFixed prec val = wrapDoubleDec val $ \case
- 0 -> zeroes (prec + 1)
- val' -> Builder $ \env buf -> withGrisu3 val' (unBuilder (doubleDec val) env buf) $ \ptr0 len e0 -> do
- bump <- roundDigit (prec + e0) len ptr0
- let dp
- | bump = e0 + 1
- | otherwise = e0
- let ptr
- | bump = ptr0
- | otherwise = ptr0 `plusPtr` 1
- let len' = 1 + prec + max 1 dp
-
- unBuilder (withPtr len' $ \dst -> do
- _ <- B.memset dst 48 $ fromIntegral len'
- if dp >= 1
- then do
- B.memcpy dst ptr $ min len dp
- pokeElemOff dst dp 46
- B.memcpy (dst `plusPtr` (dp + 1)) (ptr `plusPtr` dp) $ max 0 (len - dp)
- else do
- pokeElemOff dst 1 46
- B.memcpy (dst `plusPtr` (2 - dp)) ptr len
- return $ dst `plusPtr` len'
- ) env buf
-
-------------------------------------------------------------------------------
--- Decimal Encoding
-------------------------------------------------------------------------------
-
--- Signed integers
-------------------
-
--- | Decimal encoding of an 'Int8' using the ASCII digits.
---
--- e.g.
---
--- > toLazyByteString (int8Dec 42) = "42"
--- > toLazyByteString (int8Dec (-1)) = "-1"
---
-{-# INLINE int8Dec #-}
-int8Dec :: Int8 -> Builder
-int8Dec x = B.primBounded P.int8Dec x
-
--- | Decimal encoding of an 'Int16' using the ASCII digits.
-{-# INLINE int16Dec #-}
-int16Dec :: Int16 -> Builder
-int16Dec x = B.primBounded P.int16Dec x
-
--- | Decimal encoding of an 'Int32' using the ASCII digits.
-{-# INLINE int32Dec #-}
-int32Dec :: Int32 -> Builder
-int32Dec x = B.primBounded P.int32Dec x
-
--- | Decimal encoding of an 'Int64' using the ASCII digits.
-{-# INLINE int64Dec #-}
-int64Dec :: Int64 -> Builder
-int64Dec x = B.primBounded P.int64Dec x
-
--- | Decimal encoding of an 'Int' using the ASCII digits.
-{-# INLINE intDec #-}
-intDec :: Int -> Builder
-intDec x = B.primBounded P.intDec x
-
--- | 'intDec' with 0 padding
-intDecPadded :: Int -> Int -> Builder
-intDecPadded n = zeroPaddedBoundedPrim n P.intDec
-{-# INLINE intDecPadded #-}
-
-------------------------------------------------------------------------------
--- Hexadecimal Encoding
-------------------------------------------------------------------------------
-
--- without lead
----------------
-
--- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters.
-{-# INLINE word8Hex #-}
-word8Hex :: Word8 -> Builder
-word8Hex x = B.primBounded P.word8Hex x
-
--- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters.
-{-# INLINE word16Hex #-}
-word16Hex :: Word16 -> Builder
-word16Hex x = B.primBounded P.word16Hex x
-
--- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters.
-{-# INLINE word32Hex #-}
-word32Hex :: Word32 -> Builder
-word32Hex x = B.primBounded P.word32Hex x
-
--- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters.
-{-# INLINE word64Hex #-}
-word64Hex :: Word64 -> Builder
-word64Hex x = B.primBounded P.word64Hex x
-
--- | Shortest hexadecimal encoding of a 'Word' using lower-case characters.
-{-# INLINE wordHex #-}
-wordHex :: Word -> Builder
-wordHex x = B.primBounded P.wordHex x
-
--- fixed width; leading zeroes
-------------------------------
-
--- | Encode a 'Int8' using 2 nibbles (hexadecimal digits).
-{-# INLINE int8HexFixed #-}
-int8HexFixed :: Int8 -> Builder
-int8HexFixed x = B.primFixed P.int8HexFixed x
-
--- | Encode a 'Int16' using 4 nibbles.
-{-# INLINE int16HexFixed #-}
-int16HexFixed :: Int16 -> Builder
-int16HexFixed x = B.primFixed P.int16HexFixed x
-
--- | Encode a 'Int32' using 8 nibbles.
-{-# INLINE int32HexFixed #-}
-int32HexFixed :: Int32 -> Builder
-int32HexFixed x = B.primFixed P.int32HexFixed x
-
--- | Encode a 'Int64' using 16 nibbles.
-{-# INLINE int64HexFixed #-}
-int64HexFixed :: Int64 -> Builder
-int64HexFixed x = B.primFixed P.int64HexFixed x
-
--- | Encode a 'Word8' using 2 nibbles (hexadecimal digits).
-{-# INLINE word8HexFixed #-}
-word8HexFixed :: Word8 -> Builder
-word8HexFixed x = B.primFixed P.word8HexFixed x
-
--- | Encode a 'Word16' using 4 nibbles.
-{-# INLINE word16HexFixed #-}
-word16HexFixed :: Word16 -> Builder
-word16HexFixed x = B.primFixed P.word16HexFixed x
-
--- | Encode a 'Word32' using 8 nibbles.
-{-# INLINE word32HexFixed #-}
-word32HexFixed :: Word32 -> Builder
-word32HexFixed x = B.primFixed P.word32HexFixed x
-
--- | Encode a 'Word64' using 16 nibbles.
-{-# INLINE word64HexFixed #-}
-word64HexFixed :: Word64 -> Builder
-word64HexFixed x = B.primFixed P.word64HexFixed x
-
--- | Encode an IEEE 'Float' using 8 nibbles.
-{-# INLINE floatHexFixed #-}
-floatHexFixed :: Float -> Builder
-floatHexFixed x = B.primFixed P.floatHexFixed x
-
--- | Encode an IEEE 'Double' using 16 nibbles.
-{-# INLINE doubleHexFixed #-}
-doubleHexFixed :: Double -> Builder
-doubleHexFixed x = B.primFixed P.doubleHexFixed x
-
--- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding.
-{-# NOINLINE byteStringHex #-} -- share code
-byteStringHex :: B.ByteString -> Builder
-byteStringHex x = B.primMapByteStringFixed P.word8HexFixed x
-
--- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding.
-{-# NOINLINE lazyByteStringHex #-} -- share code
-lazyByteStringHex :: BL.ByteString -> Builder
-lazyByteStringHex x = B.primMapLazyByteStringFixed P.word8HexFixed x
-
--- | Select an implementation depending on the bit-size of 'Word's.
--- Currently, it produces a runtime failure if the bitsize is different.
--- This is detected by the testsuite.
-{-# INLINE caseWordSize_32_64 #-}
-caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's
- -> a -- Value to use for 64-bit 'Word's
- -> a
-caseWordSize_32_64 f32 f64 =
-#if MIN_VERSION_base(4,7,0)
- case finiteBitSize (undefined :: Word) of
-#else
- case bitSize (undefined :: Word) of
-#endif
- 32 -> f32
- 64 -> f64
- s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s
-
-maxPow10 :: Integer
-maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18
-
--- | Decimal encoding of an 'Integer' using the ASCII digits.
--- Simon Meier's improved implementation from https://github.com/haskell/bytestring/commit/92f19a5d94761042b44a433d7331107611e4d717
-integerDec :: Integer -> Builder
-integerDec i
- | i' <- fromInteger i, toInteger i' == i = intDec i'
- | i < 0 = primFixed P.char8 '-' `mappend` go (-i)
- | otherwise = go i
- where
- errImpossible fun =
- error $ "integerDec: " ++ fun ++ ": the impossible happened."
-
- go :: Integer -> Builder
- go n | n < maxPow10 = intDec (fromInteger n)
- | otherwise =
- case putH (splitf (maxPow10 * maxPow10) n) of
- (x:xs) -> intDec x `mappend` primMapListBounded intDecPadded18 xs
- [] -> errImpossible "integerDec: go"
-
- splitf :: Integer -> Integer -> [Integer]
- splitf pow10 n0
- | pow10 > n0 = [n0]
- | otherwise = splith (splitf (pow10 * pow10) n0)
- where
- splith [] = errImpossible "splith"
- splith (n:ns) =
- case n `quotRem` pow10 of
- (q,r) | q > 0 -> q : r : splitb ns
- | otherwise -> r : splitb ns
-
- splitb [] = []
- splitb (n:ns) = case n `quotRem` pow10 of
- (q,r) -> q : r : splitb ns
-
- putH :: [Integer] -> [Int]
- putH [] = errImpossible "putH"
- putH (n:ns) = case n `quotRem` maxPow10 of
- (x,y)
- | q > 0 -> q : r : putB ns
- | otherwise -> r : putB ns
- where q = fromInteger x
- r = fromInteger y
-
- putB :: [Integer] -> [Int]
- putB [] = []
- putB (n:ns) = case n `quotRem` maxPow10 of
- (q,r) -> fromInteger q : fromInteger r : putB ns
-{-# INLINE integerDec #-}
-
-foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9"
- c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO ()
-
-foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18"
- c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO ()
-
-{-# INLINE intDecPadded18 #-}
-intDecPadded18 :: P.BoundedPrim Int
-intDecPadded18 = P.liftFixedToBounded $ caseWordSize_32_64
- (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral)
- (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral)
-
-#if !MIN_VERSION_bytestring(0,10,12)
-boundedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
-boundedPrim = boudedPrim
-#endif
-
--- Variable-length encoding
-----
-
--- | Signed VLQ encoding (the first bit is a sign)
-intVLQ :: Int -> Builder
-intVLQ x = primBounded intVLQBP x
-{-# INLINE intVLQ #-}
-
-intVLQBP :: P.BoundedPrim Int
-intVLQBP = P.boundedPrim 10 writeIntFinite
-{-# INLINE CONLIKE intVLQBP #-}
-
--- | Unsigned VLQ encoding
-wordVLQ :: Word -> Builder
-wordVLQ x = primBounded wordVLQBP x
-
-wordVLQBP :: P.BoundedPrim Word
-wordVLQBP = P.boundedPrim 10 (writeUnsignedFinite pure)
-
-writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8)
-writeWord8 w p = do
- poke p w
- return $! plusPtr p 1
-
-writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8)
-writeIntFinite n
- | n < 0 = case negate n of
- n'
- | n' < 0x40 -> writeWord8 (fromIntegral n' `setBit` 6)
- | otherwise ->
- writeWord8 (0xc0 .|. fromIntegral n') >=>
- writeUnsignedFinite pure (unsafeShiftR n' 6)
- | n < 0x40 = writeWord8 (fromIntegral n)
- | otherwise = writeWord8 (fromIntegral n `setBit` 7 `clearBit` 6) >=>
- writeUnsignedFinite pure (unsafeShiftR n 6)
-{-# INLINE writeIntFinite #-}
-
-writeUnsignedFinite :: (Bits a, Integral a) => (Ptr Word8 -> IO r) -> a -> Ptr Word8 -> IO r
-writeUnsignedFinite k = go
- where
- go m
- | m < 0x80 = writeWord8 (fromIntegral m) >=> k
- | otherwise = writeWord8 (setBit (fromIntegral m) 7) >=> go (unsafeShiftR m 7)
-{-# INLINE writeUnsignedFinite #-}
-
--- | Encode a Word in
-prefixVarInt :: Word -> Builder
-prefixVarInt x = primBounded prefixVarIntBP x
-
-prefixVarIntBP :: P.BoundedPrim Word
-prefixVarIntBP = P.boundedPrim 9 $ \x ptr0 -> do
- let bits = 64 - countLeadingZeros (x .|. 1)
- if bits > 56
- then do
- poke ptr0 0
- poke (castPtr ptr0 `plusPtr` 1) x
- return $! ptr0 `plusPtr` 9
- else do
- let bytes = 1 + (bits - 1) `div` 7
- let end = ptr0 `plusPtr` bytes
- let go ptr n
- | ptr == end = pure ptr
- | otherwise = do
- poke ptr (fromIntegral n .&. 0xff)
- go (ptr `plusPtr` 1) (n `shiftR` 8)
- go ptr0 $! (2 * x + 1) `shiftL` (bytes - 1)
-{-# INLINE CONLIKE prefixVarIntBP #-}
-
-intersperse :: (Foldable f, Buildable e) => BuilderFor e -> f (BuilderFor e) -> BuilderFor e
-intersperse d = go . toList where
- go (x0 : xs) = x0 <> foldr (\x r -> d <> x <> r) mempty xs
- go [] = mempty
-{-# INLINE intersperse #-}
-
-unwords :: (Foldable f, Buildable e) => f (BuilderFor e) -> BuilderFor e
-unwords = intersperse (word8 32)
-{-# INLINE unwords #-}
-
-unlines :: (Foldable f, Buildable e) => f (BuilderFor e) -> BuilderFor e
-unlines = foldMap (<>word8 10)
-{-# INLINE unlines #-}
-
--- | Turn a value into a 'Builder' using the 'Show' instance.
-viaShow :: Show a => a -> Builder
-viaShow x = string8 (show x)
+{-# LANGUAGE MagicHash, CPP, UnboxedTuples #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
+----------------------------------------------------------------------------
+-- |
+-- Module : Mason.Builder
+-- Copyright : (c) Fumiaki Kinoshita 2019-
+-- License : BSD3
+--
+-- Maintainer : Fumiaki Kinoshita
+--
+----------------------------------------------------------------------------
+module Mason.Builder
+ ( Builder
+ , BuilderFor
+ , Buildable
+ -- * Runners
+ , StrictByteStringBackend
+ , toStrictByteString
+ , LazyByteStringBackend
+ , toLazyByteString
+ , BufferedIOBackend
+ , hPutBuilderLen
+ , hPutBuilder
+ , sendBuilder
+ , withPopper
+ , StreamingBackend
+ , toStreamingBody
+ -- * Primitives
+ , flush
+ -- * Bytes
+ , byteString
+ , lazyByteString
+ , shortByteString
+ -- * Text
+ , textUtf8
+ , encodeUtf8Builder
+ , encodeUtf8BuilderEscaped
+ , char7
+ , string7
+ , char8
+ , string8
+ , charUtf8
+ , stringUtf8
+ -- * Primitive
+ , storable
+ , int8
+ , word8
+ , int16LE
+ , int32LE
+ , int64LE
+ , word16LE
+ , word32LE
+ , word64LE
+ , floatLE
+ , doubleLE
+ , int16BE
+ , int32BE
+ , int64BE
+ , word16BE
+ , word32BE
+ , word64BE
+ , floatBE
+ , doubleBE
+ -- * Numeral
+ , floatDec
+ , doubleDec
+ , doubleSI
+ , doubleExp
+ , doubleFixed
+ , word8Dec
+ , word16Dec
+ , word32Dec
+ , word64Dec
+ , wordDec
+ , int8Dec
+ , int16Dec
+ , int32Dec
+ , int64Dec
+ , intDec
+ , intDecPadded
+ , integerDec
+ , word8Hex
+ , word16Hex
+ , word32Hex
+ , word64Hex
+ , wordHex
+ , int8HexFixed
+ , int16HexFixed
+ , int32HexFixed
+ , int64HexFixed
+ , word8HexFixed
+ , word16HexFixed
+ , word32HexFixed
+ , word64HexFixed
+ , floatHexFixed
+ , doubleHexFixed
+ , byteStringHex
+ , lazyByteStringHex
+ -- * Variable-length encoding
+ , intVLQ
+ , intVLQBP
+ , wordVLQ
+ , wordVLQBP
+ , prefixVarInt
+ , prefixVarIntBP
+ -- * Combinators
+ , intersperse
+ , Mason.Builder.unwords
+ , Mason.Builder.unlines
+ , viaShow
+ -- * Advanced
+ , paddedBoundedPrim
+ , zeroPaddedBoundedPrim
+ , primFixed
+ , primBounded
+ , lengthPrefixedWithin
+
+ ) where
+
+import Control.Monad
+import qualified Data.Array as A
+import Data.Bits
+import Data.Foldable (toList)
+import Data.Word
+import Data.Int
+import qualified Data.Text as T
+import Foreign.C.Types
+import Foreign.Ptr (Ptr, plusPtr, castPtr)
+import Foreign.Storable
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as B
+import qualified Data.ByteString.Lazy as BL
+import Mason.Builder.Internal as B
+import qualified Data.ByteString.Builder.Prim as P
+import qualified Data.ByteString.Builder.Prim.Internal as P
+#if !MIN_VERSION_bytestring(0,10,12)
+import Data.ByteString.Builder.Prim (boudedPrim)
+#endif
+import System.IO (Handle)
+
+-- | Put the content of a 'Builder' to a 'Handle'.
+hPutBuilder :: Handle -> BuilderFor PutEnv -> IO ()
+hPutBuilder h b = void $ hPutBuilderLen h b
+{-# INLINE hPutBuilder #-}
+
+-- | Combine chunks of a lazy 'BL.ByteString'
+lazyByteString :: BL.ByteString -> Builder
+lazyByteString x = foldMap byteString (BL.toChunks x)
+{-# INLINE lazyByteString #-}
+
+------------------------------------------------------------------------------
+-- Binary encodings
+------------------------------------------------------------------------------
+
+-- | Encode a single signed byte as-is.
+--
+{-# INLINE int8 #-}
+int8 :: Int8 -> Builder
+int8 x = B.primFixed P.int8 x
+
+-- | Encode a single unsigned byte as-is.
+--
+{-# INLINE word8 #-}
+word8 :: Word8 -> Builder
+word8 x = B.primFixed P.word8 x
+
+
+------------------------------------------------------------------------------
+-- Binary little-endian encodings
+------------------------------------------------------------------------------
+
+-- | Encode an 'Int16' in little endian format.
+{-# INLINE int16LE #-}
+int16LE :: Int16 -> Builder
+int16LE x = B.primFixed P.int16LE x
+
+-- | Encode an 'Int32' in little endian format.
+{-# INLINE int32LE #-}
+int32LE :: Int32 -> Builder
+int32LE x = B.primFixed P.int32LE x
+
+-- | Encode an 'Int64' in little endian format.
+{-# INLINE int64LE #-}
+int64LE :: Int64 -> Builder
+int64LE x = B.primFixed P.int64LE x
+
+-- | Encode a 'Word16' in little endian format.
+{-# INLINE word16LE #-}
+word16LE :: Word16 -> Builder
+word16LE x = B.primFixed P.word16LE x
+
+-- | Encode a 'Word32' in little endian format.
+{-# INLINE word32LE #-}
+word32LE :: Word32 -> Builder
+word32LE x = B.primFixed P.word32LE x
+
+-- | Encode a 'Word64' in little endian format.
+{-# INLINE word64LE #-}
+word64LE :: Word64 -> Builder
+word64LE x = B.primFixed P.word64LE x
+
+-- | Encode a 'Float' in little endian format.
+{-# INLINE floatLE #-}
+floatLE :: Float -> Builder
+floatLE x = B.primFixed P.floatLE x
+
+-- | Encode a 'Double' in little endian format.
+{-# INLINE doubleLE #-}
+doubleLE :: Double -> Builder
+doubleLE x = B.primFixed P.doubleLE x
+
+
+------------------------------------------------------------------------------
+-- Binary big-endian encodings
+------------------------------------------------------------------------------
+
+-- | Encode an 'Int16' in big endian format.
+{-# INLINE int16BE #-}
+int16BE :: Int16 -> Builder
+int16BE x = B.primFixed P.int16BE x
+
+-- | Encode an 'Int32' in big endian format.
+{-# INLINE int32BE #-}
+int32BE :: Int32 -> Builder
+int32BE x = B.primFixed P.int32BE x
+
+-- | Encode an 'Int64' in big endian format.
+{-# INLINE int64BE #-}
+int64BE :: Int64 -> Builder
+int64BE x = B.primFixed P.int64BE x
+
+-- | Encode a 'Word16' in big endian format.
+{-# INLINE word16BE #-}
+word16BE :: Word16 -> Builder
+word16BE x = B.primFixed P.word16BE x
+
+-- | Encode a 'Word32' in big endian format.
+{-# INLINE word32BE #-}
+word32BE :: Word32 -> Builder
+word32BE x = B.primFixed P.word32BE x
+
+-- | Encode a 'Word64' in big endian format.
+{-# INLINE word64BE #-}
+word64BE :: Word64 -> Builder
+word64BE x = B.primFixed P.word64BE x
+
+-- | Encode a 'Float' in big endian format.
+{-# INLINE floatBE #-}
+floatBE :: Float -> Builder
+floatBE x = B.primFixed P.floatBE x
+
+-- | Encode a 'Double' in big endian format.
+{-# INLINE doubleBE #-}
+doubleBE :: Double -> Builder
+doubleBE x = B.primFixed P.doubleBE x
+
+------------------------------------------------------------------------------
+-- ASCII encoding
+------------------------------------------------------------------------------
+
+-- | Char7 encode a 'Char'.
+{-# INLINE char7 #-}
+char7 :: Char -> Builder
+char7 x = B.primFixed P.char7 x
+
+-- | Char7 encode a 'String'.
+{-# INLINE string7 #-}
+string7 :: String -> Builder
+string7 x = B.primMapListFixed P.char7 x
+
+------------------------------------------------------------------------------
+-- ISO/IEC 8859-1 encoding
+------------------------------------------------------------------------------
+
+-- | Char8 encode a 'Char'.
+{-# INLINE char8 #-}
+char8 :: Char -> Builder
+char8 x = B.primFixed P.char8 x
+
+-- | Char8 encode a 'String'.
+{-# INLINE string8 #-}
+string8 :: String -> Builder
+string8 x = B.primMapListFixed P.char8 x
+
+------------------------------------------------------------------------------
+-- UTF-8 encoding
+------------------------------------------------------------------------------
+
+-- | UTF-8 encode a 'Char'.
+{-# INLINE charUtf8 #-}
+charUtf8 :: Char -> Builder
+charUtf8 x = B.primBounded P.charUtf8 x
+
+-- | Encode 'T.Text' as a UTF-8 byte stream. Synonym for 'textUtf8'.
+encodeUtf8Builder :: T.Text -> Builder
+encodeUtf8Builder x = textUtf8 x
+{-# INLINE encodeUtf8Builder #-}
+
+-- | Encode 'T.Text' as a UTF-8 byte stream.
+textUtf8 :: T.Text -> Builder
+textUtf8 x = B.encodeUtf8BuilderEscaped (P.liftFixedToBounded P.word8) x
+{-# INLINE textUtf8 #-}
+
+--------------------
+-- Unsigned integers
+--------------------
+
+-- | Decimal encoding of a 'Word8' using the ASCII digits.
+{-# INLINE word8Dec #-}
+word8Dec :: Word8 -> Builder
+word8Dec x = B.primBounded P.word8Dec x
+
+-- | Decimal encoding of a 'Word16' using the ASCII digits.
+{-# INLINE word16Dec #-}
+word16Dec :: Word16 -> Builder
+word16Dec x = B.primBounded P.word16Dec x
+
+-- | Decimal encoding of a 'Word32' using the ASCII digits.
+{-# INLINE word32Dec #-}
+word32Dec :: Word32 -> Builder
+word32Dec x = B.primBounded P.word32Dec x
+
+-- | Decimal encoding of a 'Word64' using the ASCII digits.
+{-# INLINE word64Dec #-}
+word64Dec :: Word64 -> Builder
+word64Dec x = B.primBounded P.word64Dec x
+
+-- | Decimal encoding of a 'Word' using the ASCII digits.
+{-# INLINE wordDec #-}
+wordDec :: Word -> Builder
+wordDec x = B.primBounded P.wordDec x
+
+-- Floating point numbers
+-------------------------
+
+-- | /Currently slow./ Decimal encoding of an IEEE 'Float'.
+{-# INLINE floatDec #-}
+floatDec :: Float -> Builder
+floatDec x = string7 (show x)
+
+wrapDoubleDec :: Double -> (Double -> Builder) -> Builder
+wrapDoubleDec x k
+ | isNaN x = string7 "NaN"
+ | isInfinite x = if x < 0 then string7 "-Infinity" else string7 "Infinity"
+ | isNegativeZero x = char7 '-' <> k 0.0
+ | x < 0 = char7 '-' <> k (-x)
+ | otherwise = k x
+{-# INLINE wrapDoubleDec #-}
+
+-- | Decimal encoding of an IEEE 'Double'.
+{-# INLINE doubleDec #-}
+doubleDec :: Double -> Builder
+doubleDec val = wrapDoubleDec val $ \case
+ 0 -> string7 "0.0"
+ x -> grisu x
+ where
+ grisu v = withPtr 24 $ \ptr -> do
+ n <- dtoa_grisu3 v ptr
+ return $ plusPtr ptr (fromIntegral n)
+
+foreign import ccall unsafe "static dtoa_grisu3"
+ dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt
+
+-- | Attach an SI prefix so that abs(mantissa) is within [1, 1000). Omits c, d, da and h.
+doubleSI :: Int -- ^ precision: must be equal or greater than 3
+ -> Double
+ -> Builder
+doubleSI prec _ | prec < 3 = error "Mason.Builder.doubleSI: precision less than 3"
+doubleSI prec val = wrapDoubleDec val $ \case
+ 0 -> zeroes prec
+ val' -> Builder $ \env buf -> withGrisu3Rounded prec val' $ \ptr len e -> do
+ let (pindex, dp) = divMod (e - 1) 3
+ print (dp, prec, len)
+ let mantissa
+ -- when the decimal separator would be at the end
+ | dp + 1 == prec = withPtr (prec + dp - 2) $ \dst -> do
+ _ <- B.memset dst 48 $ fromIntegral (prec + dp - 2)
+ B.memcpy dst ptr $ min len prec
+ return $ dst `plusPtr` (prec + dp - 2)
+ | otherwise = withPtr (prec + 1) $ \dst -> do
+ _ <- B.memset dst 48 $ fromIntegral (prec + 1)
+ B.memcpy dst ptr $ min len $ dp + 1
+ pokeElemOff dst (dp + 1) 46
+ B.memcpy (dst `plusPtr` (dp + 2)) (ptr `plusPtr` (dp + 1)) $ max 0 $ len - dp - 1
+ return $ dst `plusPtr` (prec + 1)
+ let prefix
+ | pindex == 0 = mempty
+ | pindex > 8 || pindex < (-8) = char7 'e' <> intDec (3 * pindex)
+ | otherwise = charUtf8 (prefices A.! pindex)
+ unBuilder (mantissa <> prefix) env buf
+ where
+ prefices = A.listArray (-8,8) "yzafpnμm\NULkMGTPEZY"
+
+zeroes :: Int -> Builder
+zeroes n = withPtr (n + 1) $ \dst -> do
+ _ <- B.memset dst 48 $ fromIntegral $ n + 1
+ pokeElemOff dst 1 46
+ return $ dst `plusPtr` (n + 1)
+
+-- | Always use exponents
+doubleExp :: Int -- ^ number of digits in the mantissa
+ -> Double
+ -> Builder
+doubleExp prec _ | prec < 1 = error "Mason.Builder.doubleFixed: precision too small"
+doubleExp prec val = wrapDoubleDec val $ \case
+ 0 -> zeroes prec <> string7 "e0"
+ val' -> Builder $ \env buf -> withGrisu3Rounded prec val' $ \ptr len dp -> do
+ let len' = 1 + prec
+
+ firstDigit <- peek ptr
+
+ unBuilder (withPtr len' (\dst -> do
+ _ <- B.memset dst 48 $ fromIntegral len'
+ poke dst firstDigit
+ poke (dst `plusPtr` 1) (46 :: Word8)
+ B.memcpy (dst `plusPtr` 2) (ptr `plusPtr` 1) (min (len - 1) len')
+ return (dst `plusPtr` len'))
+ <> char7 'e' <> intDec (dp - 1)) env buf
+
+-- | Fixed precision
+doubleFixed :: Int -- ^ decimal points
+ -> Double
+ -> Builder
+doubleFixed 0 val = intDec (round val)
+doubleFixed prec _ | prec < 0 = error "Mason.Builder.doubleFixed: negative precision"
+doubleFixed prec val = wrapDoubleDec val $ \case
+ 0 -> zeroes (prec + 1)
+ val' -> Builder $ \env buf -> withGrisu3 val' (unBuilder (doubleDec val) env buf) $ \ptr0 len e0 -> do
+ bump <- roundDigit (prec + e0) len ptr0
+ let dp
+ | bump = e0 + 1
+ | otherwise = e0
+ let ptr
+ | bump = ptr0
+ | otherwise = ptr0 `plusPtr` 1
+ let len' = 1 + prec + max 1 dp
+
+ unBuilder (withPtr len' $ \dst -> do
+ _ <- B.memset dst 48 $ fromIntegral len'
+ if dp >= 1
+ then do
+ B.memcpy dst ptr $ min len dp
+ pokeElemOff dst dp 46
+ B.memcpy (dst `plusPtr` (dp + 1)) (ptr `plusPtr` dp) $ max 0 (len - dp)
+ else do
+ pokeElemOff dst 1 46
+ B.memcpy (dst `plusPtr` (2 - dp)) ptr len
+ return $ dst `plusPtr` len'
+ ) env buf
+
+------------------------------------------------------------------------------
+-- Decimal Encoding
+------------------------------------------------------------------------------
+
+-- Signed integers
+------------------
+
+-- | Decimal encoding of an 'Int8' using the ASCII digits.
+--
+-- e.g.
+--
+-- > toLazyByteString (int8Dec 42) = "42"
+-- > toLazyByteString (int8Dec (-1)) = "-1"
+--
+{-# INLINE int8Dec #-}
+int8Dec :: Int8 -> Builder
+int8Dec x = B.primBounded P.int8Dec x
+
+-- | Decimal encoding of an 'Int16' using the ASCII digits.
+{-# INLINE int16Dec #-}
+int16Dec :: Int16 -> Builder
+int16Dec x = B.primBounded P.int16Dec x
+
+-- | Decimal encoding of an 'Int32' using the ASCII digits.
+{-# INLINE int32Dec #-}
+int32Dec :: Int32 -> Builder
+int32Dec x = B.primBounded P.int32Dec x
+
+-- | Decimal encoding of an 'Int64' using the ASCII digits.
+{-# INLINE int64Dec #-}
+int64Dec :: Int64 -> Builder
+int64Dec x = B.primBounded P.int64Dec x
+
+-- | Decimal encoding of an 'Int' using the ASCII digits.
+{-# INLINE intDec #-}
+intDec :: Int -> Builder
+intDec x = B.primBounded P.intDec x
+
+-- | 'intDec' with 0 padding
+intDecPadded :: Int -> Int -> Builder
+intDecPadded n = zeroPaddedBoundedPrim n P.intDec
+{-# INLINE intDecPadded #-}
+
+------------------------------------------------------------------------------
+-- Hexadecimal Encoding
+------------------------------------------------------------------------------
+
+-- without lead
+---------------
+
+-- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters.
+{-# INLINE word8Hex #-}
+word8Hex :: Word8 -> Builder
+word8Hex x = B.primBounded P.word8Hex x
+
+-- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters.
+{-# INLINE word16Hex #-}
+word16Hex :: Word16 -> Builder
+word16Hex x = B.primBounded P.word16Hex x
+
+-- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters.
+{-# INLINE word32Hex #-}
+word32Hex :: Word32 -> Builder
+word32Hex x = B.primBounded P.word32Hex x
+
+-- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters.
+{-# INLINE word64Hex #-}
+word64Hex :: Word64 -> Builder
+word64Hex x = B.primBounded P.word64Hex x
+
+-- | Shortest hexadecimal encoding of a 'Word' using lower-case characters.
+{-# INLINE wordHex #-}
+wordHex :: Word -> Builder
+wordHex x = B.primBounded P.wordHex x
+
+-- fixed width; leading zeroes
+------------------------------
+
+-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits).
+{-# INLINE int8HexFixed #-}
+int8HexFixed :: Int8 -> Builder
+int8HexFixed x = B.primFixed P.int8HexFixed x
+
+-- | Encode a 'Int16' using 4 nibbles.
+{-# INLINE int16HexFixed #-}
+int16HexFixed :: Int16 -> Builder
+int16HexFixed x = B.primFixed P.int16HexFixed x
+
+-- | Encode a 'Int32' using 8 nibbles.
+{-# INLINE int32HexFixed #-}
+int32HexFixed :: Int32 -> Builder
+int32HexFixed x = B.primFixed P.int32HexFixed x
+
+-- | Encode a 'Int64' using 16 nibbles.
+{-# INLINE int64HexFixed #-}
+int64HexFixed :: Int64 -> Builder
+int64HexFixed x = B.primFixed P.int64HexFixed x
+
+-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits).
+{-# INLINE word8HexFixed #-}
+word8HexFixed :: Word8 -> Builder
+word8HexFixed x = B.primFixed P.word8HexFixed x
+
+-- | Encode a 'Word16' using 4 nibbles.
+{-# INLINE word16HexFixed #-}
+word16HexFixed :: Word16 -> Builder
+word16HexFixed x = B.primFixed P.word16HexFixed x
+
+-- | Encode a 'Word32' using 8 nibbles.
+{-# INLINE word32HexFixed #-}
+word32HexFixed :: Word32 -> Builder
+word32HexFixed x = B.primFixed P.word32HexFixed x
+
+-- | Encode a 'Word64' using 16 nibbles.
+{-# INLINE word64HexFixed #-}
+word64HexFixed :: Word64 -> Builder
+word64HexFixed x = B.primFixed P.word64HexFixed x
+
+-- | Encode an IEEE 'Float' using 8 nibbles.
+{-# INLINE floatHexFixed #-}
+floatHexFixed :: Float -> Builder
+floatHexFixed x = B.primFixed P.floatHexFixed x
+
+-- | Encode an IEEE 'Double' using 16 nibbles.
+{-# INLINE doubleHexFixed #-}
+doubleHexFixed :: Double -> Builder
+doubleHexFixed x = B.primFixed P.doubleHexFixed x
+
+-- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding.
+{-# NOINLINE byteStringHex #-} -- share code
+byteStringHex :: B.ByteString -> Builder
+byteStringHex x = B.primMapByteStringFixed P.word8HexFixed x
+
+-- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding.
+{-# NOINLINE lazyByteStringHex #-} -- share code
+lazyByteStringHex :: BL.ByteString -> Builder
+lazyByteStringHex x = B.primMapLazyByteStringFixed P.word8HexFixed x
+
+-- | Select an implementation depending on the bit-size of 'Word's.
+-- Currently, it produces a runtime failure if the bitsize is different.
+-- This is detected by the testsuite.
+{-# INLINE caseWordSize_32_64 #-}
+caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's
+ -> a -- Value to use for 64-bit 'Word's
+ -> a
+caseWordSize_32_64 f32 f64 =
+#if MIN_VERSION_base(4,7,0)
+ case finiteBitSize (undefined :: Word) of
+#else
+ case bitSize (undefined :: Word) of
+#endif
+ 32 -> f32
+ 64 -> f64
+ s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s
+
+maxPow10 :: Integer
+maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18
+
+-- | Decimal encoding of an 'Integer' using the ASCII digits.
+-- Simon Meier's improved implementation from https://github.com/haskell/bytestring/commit/92f19a5d94761042b44a433d7331107611e4d717
+integerDec :: Integer -> Builder
+integerDec i
+ | i' <- fromInteger i, toInteger i' == i = intDec i'
+ | i < 0 = primFixed P.char8 '-' `mappend` go (-i)
+ | otherwise = go i
+ where
+ errImpossible fun =
+ error $ "integerDec: " ++ fun ++ ": the impossible happened."
+
+ go :: Integer -> Builder
+ go n | n < maxPow10 = intDec (fromInteger n)
+ | otherwise =
+ case putH (splitf (maxPow10 * maxPow10) n) of
+ (x:xs) -> intDec x `mappend` primMapListBounded intDecPadded18 xs
+ [] -> errImpossible "integerDec: go"
+
+ splitf :: Integer -> Integer -> [Integer]
+ splitf pow10 n0
+ | pow10 > n0 = [n0]
+ | otherwise = splith (splitf (pow10 * pow10) n0)
+ where
+ splith [] = errImpossible "splith"
+ splith (n:ns) =
+ case n `quotRem` pow10 of
+ (q,r) | q > 0 -> q : r : splitb ns
+ | otherwise -> r : splitb ns
+
+ splitb [] = []
+ splitb (n:ns) = case n `quotRem` pow10 of
+ (q,r) -> q : r : splitb ns
+
+ putH :: [Integer] -> [Int]
+ putH [] = errImpossible "putH"
+ putH (n:ns) = case n `quotRem` maxPow10 of
+ (x,y)
+ | q > 0 -> q : r : putB ns
+ | otherwise -> r : putB ns
+ where q = fromInteger x
+ r = fromInteger y
+
+ putB :: [Integer] -> [Int]
+ putB [] = []
+ putB (n:ns) = case n `quotRem` maxPow10 of
+ (q,r) -> fromInteger q : fromInteger r : putB ns
+{-# INLINE integerDec #-}
+
+foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9"
+ c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO ()
+
+foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18"
+ c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO ()
+
+{-# INLINE intDecPadded18 #-}
+intDecPadded18 :: P.BoundedPrim Int
+intDecPadded18 = P.liftFixedToBounded $ caseWordSize_32_64
+ (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral)
+ (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral)
+
+#if !MIN_VERSION_bytestring(0,10,12)
+boundedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
+boundedPrim = boudedPrim
+#endif
+
+-- Variable-length encoding
+----
+
+-- | Signed VLQ encoding (the first bit is a sign)
+intVLQ :: Int -> Builder
+intVLQ x = primBounded intVLQBP x
+{-# INLINE intVLQ #-}
+
+intVLQBP :: P.BoundedPrim Int
+intVLQBP = P.boundedPrim 10 writeIntFinite
+{-# INLINE CONLIKE intVLQBP #-}
+
+-- | Unsigned VLQ encoding
+wordVLQ :: Word -> Builder
+wordVLQ x = primBounded wordVLQBP x
+
+wordVLQBP :: P.BoundedPrim Word
+wordVLQBP = P.boundedPrim 10 (writeUnsignedFinite pure)
+
+writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8)
+writeWord8 w p = do
+ poke p w
+ return $! plusPtr p 1
+
+writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8)
+writeIntFinite n
+ | n < 0 = case negate n of
+ n'
+ | n' < 0x40 -> writeWord8 (fromIntegral n' `setBit` 6)
+ | otherwise ->
+ writeWord8 (0xc0 .|. fromIntegral n') >=>
+ writeUnsignedFinite pure (unsafeShiftR n' 6)
+ | n < 0x40 = writeWord8 (fromIntegral n)
+ | otherwise = writeWord8 (fromIntegral n `setBit` 7 `clearBit` 6) >=>
+ writeUnsignedFinite pure (unsafeShiftR n 6)
+{-# INLINE writeIntFinite #-}
+
+writeUnsignedFinite :: (Bits a, Integral a) => (Ptr Word8 -> IO r) -> a -> Ptr Word8 -> IO r
+writeUnsignedFinite k = go
+ where
+ go m
+ | m < 0x80 = writeWord8 (fromIntegral m) >=> k
+ | otherwise = writeWord8 (setBit (fromIntegral m) 7) >=> go (unsafeShiftR m 7)
+{-# INLINE writeUnsignedFinite #-}
+
+-- | Encode a Word in
+prefixVarInt :: Word -> Builder
+prefixVarInt x = primBounded prefixVarIntBP x
+
+prefixVarIntBP :: P.BoundedPrim Word
+prefixVarIntBP = P.boundedPrim 9 $ \x ptr0 -> do
+ let bits = 64 - countLeadingZeros (x .|. 1)
+ if bits > 56
+ then do
+ poke ptr0 0
+ poke (castPtr ptr0 `plusPtr` 1) x
+ return $! ptr0 `plusPtr` 9
+ else do
+ let bytes = 1 + (bits - 1) `div` 7
+ let end = ptr0 `plusPtr` bytes
+ let go ptr n
+ | ptr == end = pure ptr
+ | otherwise = do
+ poke ptr (fromIntegral n .&. 0xff)
+ go (ptr `plusPtr` 1) (n `shiftR` 8)
+ go ptr0 $! (2 * x + 1) `shiftL` (bytes - 1)
+{-# INLINE CONLIKE prefixVarIntBP #-}
+
+intersperse :: (Foldable f, Buildable e) => BuilderFor e -> f (BuilderFor e) -> BuilderFor e
+intersperse d = go . toList where
+ go (x0 : xs) = x0 <> foldr (\x r -> d <> x <> r) mempty xs
+ go [] = mempty
+{-# INLINE intersperse #-}
+
+unwords :: (Foldable f, Buildable e) => f (BuilderFor e) -> BuilderFor e
+unwords = intersperse (word8 32)
+{-# INLINE unwords #-}
+
+unlines :: (Foldable f, Buildable e) => f (BuilderFor e) -> BuilderFor e
+unlines = foldMap (<>word8 10)
+{-# INLINE unlines #-}
+
+-- | Turn a value into a 'Builder' using the 'Show' instance.
+viaShow :: Show a => a -> Builder
+viaShow x = string8 (show x)
{-# INLINE viaShow #-}
diff --git a/src/Mason/Builder/Compat.hs b/src/Mason/Builder/Compat.hs
--- a/src/Mason/Builder/Compat.hs
+++ b/src/Mason/Builder/Compat.hs
@@ -1,93 +1,93 @@
-----------------------------------------------------------------------------
--- |
--- Module : Mason.Builder.Compat
--- Copyright : (c) Fumiaki Kinoshita 2020-
--- License : BSD3
---
--- Maintainer : Fumiaki Kinoshita
---
--- API which is almost compatible with Data.ByteString.Builder
-----------------------------------------------------------------------------
-module Mason.Builder.Compat
- ( Builder
- -- * Runners
- , D.toStrictByteString
- , D.toLazyByteString
- , D.hPutBuilderLen
- , D.hPutBuilder
- , D.sendBuilder
- -- * Primitives
- , flush
- -- * Bytes
- , byteString
- , lazyByteString
- , shortByteString
- -- * Text
- , textUtf8
- , encodeUtf8Builder
- , encodeUtf8BuilderEscaped
- , char7
- , string7
- , char8
- , string8
- , charUtf8
- , stringUtf8
- -- * Primitive
- , storable
- , int8
- , word8
- , int16LE
- , int32LE
- , int64LE
- , word16LE
- , word32LE
- , word64LE
- , floatLE
- , doubleLE
- , int16BE
- , int32BE
- , int64BE
- , word16BE
- , word32BE
- , word64BE
- , floatBE
- , doubleBE
- -- * Numeral
- , floatDec
- , doubleDec
- , doubleSI
- , doubleExp
- , doubleFixed
- , word8Dec
- , word16Dec
- , word32Dec
- , word64Dec
- , wordDec
- , int8Dec
- , int16Dec
- , int32Dec
- , int64Dec
- , intDec
- , integerDec
- , word8Hex
- , word16Hex
- , word32Hex
- , word64Hex
- , wordHex
- , int8HexFixed
- , int16HexFixed
- , int32HexFixed
- , int64HexFixed
- , word8HexFixed
- , word16HexFixed
- , word32HexFixed
- , word64HexFixed
- , floatHexFixed
- , doubleHexFixed
- , byteStringHex
- , lazyByteStringHex
- ) where
-import Mason.Builder hiding (Builder)
-import Mason.Builder.Dynamic as D
-
+----------------------------------------------------------------------------
+-- |
+-- Module : Mason.Builder.Compat
+-- Copyright : (c) Fumiaki Kinoshita 2020-
+-- License : BSD3
+--
+-- Maintainer : Fumiaki Kinoshita
+--
+-- API which is almost compatible with Data.ByteString.Builder
+----------------------------------------------------------------------------
+module Mason.Builder.Compat
+ ( Builder
+ -- * Runners
+ , D.toStrictByteString
+ , D.toLazyByteString
+ , D.hPutBuilderLen
+ , D.hPutBuilder
+ , D.sendBuilder
+ -- * Primitives
+ , flush
+ -- * Bytes
+ , byteString
+ , lazyByteString
+ , shortByteString
+ -- * Text
+ , textUtf8
+ , encodeUtf8Builder
+ , encodeUtf8BuilderEscaped
+ , char7
+ , string7
+ , char8
+ , string8
+ , charUtf8
+ , stringUtf8
+ -- * Primitive
+ , storable
+ , int8
+ , word8
+ , int16LE
+ , int32LE
+ , int64LE
+ , word16LE
+ , word32LE
+ , word64LE
+ , floatLE
+ , doubleLE
+ , int16BE
+ , int32BE
+ , int64BE
+ , word16BE
+ , word32BE
+ , word64BE
+ , floatBE
+ , doubleBE
+ -- * Numeral
+ , floatDec
+ , doubleDec
+ , doubleSI
+ , doubleExp
+ , doubleFixed
+ , word8Dec
+ , word16Dec
+ , word32Dec
+ , word64Dec
+ , wordDec
+ , int8Dec
+ , int16Dec
+ , int32Dec
+ , int64Dec
+ , intDec
+ , integerDec
+ , word8Hex
+ , word16Hex
+ , word32Hex
+ , word64Hex
+ , wordHex
+ , int8HexFixed
+ , int16HexFixed
+ , int32HexFixed
+ , int64HexFixed
+ , word8HexFixed
+ , word16HexFixed
+ , word32HexFixed
+ , word64HexFixed
+ , floatHexFixed
+ , doubleHexFixed
+ , byteStringHex
+ , lazyByteStringHex
+ ) where
+import Mason.Builder hiding (Builder)
+import Mason.Builder.Dynamic as D
+
type Builder = D.DynBuilder
diff --git a/src/Mason/Builder/Dynamic.hs b/src/Mason/Builder/Dynamic.hs
--- a/src/Mason/Builder/Dynamic.hs
+++ b/src/Mason/Builder/Dynamic.hs
@@ -1,63 +1,63 @@
-module Mason.Builder.Dynamic
- ( DynBuilder
- , DynamicBackend(..)
- -- * Runners
- , toStrictByteString
- , toLazyByteString
- , hPutBuilderLen
- , hPutBuilder
- , sendBuilder
- ) where
-
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL
-import qualified Mason.Builder as B
-import qualified Mason.Builder.Internal as B
-import Network.Socket (Socket)
-import System.IO (Handle)
-
-data DynamicBackend = DynGrowingBuffer !B.GrowingBuffer
- | DynChannel !B.Channel
- | DynPutEnv !B.PutEnv
-
-instance B.Buildable DynamicBackend where
- byteString bs = B.Builder $ \env buf -> case env of
- DynGrowingBuffer e -> B.unBuilder (B.byteString bs) e buf
- DynChannel e -> B.unBuilder (B.byteString bs) e buf
- DynPutEnv e -> B.unBuilder (B.byteString bs) e buf
- {-# INLINE byteString #-}
- flush = B.Builder $ \env buf -> case env of
- DynGrowingBuffer e -> B.unBuilder B.flush e buf
- DynChannel e -> B.unBuilder B.flush e buf
- DynPutEnv e -> B.unBuilder B.flush e buf
- {-# INLINE flush #-}
- allocate n = B.Builder $ \env buf -> case env of
- DynGrowingBuffer e -> B.unBuilder (B.allocate n) e buf
- DynChannel e -> B.unBuilder (B.allocate n) e buf
- DynPutEnv e -> B.unBuilder (B.allocate n) e buf
- {-# INLINE allocate #-}
-
--- | Builder with a fixed set of backends. This helps reducing code size
--- and unoptimised code especially on complex/recursive structures, at the cost of
--- extensibility.
-type DynBuilder = B.BuilderFor DynamicBackend
-
-toStrictByteString :: DynBuilder -> B.ByteString
-toStrictByteString b = B.toStrictByteString $ B.Builder $ B.unBuilder b . DynGrowingBuffer
-{-# INLINE toStrictByteString #-}
-
-toLazyByteString :: DynBuilder -> BL.ByteString
-toLazyByteString b = B.toLazyByteString $ B.Builder $ B.unBuilder b . DynChannel
-{-# INLINE toLazyByteString #-}
-
-hPutBuilder :: Handle -> DynBuilder -> IO ()
-hPutBuilder h b = B.hPutBuilder h $ B.Builder $ B.unBuilder b . DynPutEnv
-{-# INLINE hPutBuilder #-}
-
-hPutBuilderLen :: Handle -> DynBuilder -> IO Int
-hPutBuilderLen h b = B.hPutBuilderLen h $ B.Builder $ B.unBuilder b . DynPutEnv
-{-# INLINE hPutBuilderLen #-}
-
-sendBuilder :: Socket -> DynBuilder -> IO Int
-sendBuilder h b = B.sendBuilder h $ B.Builder $ B.unBuilder b . DynPutEnv
-{-# INLINE sendBuilder #-}
+module Mason.Builder.Dynamic
+ ( DynBuilder
+ , DynamicBackend(..)
+ -- * Runners
+ , toStrictByteString
+ , toLazyByteString
+ , hPutBuilderLen
+ , hPutBuilder
+ , sendBuilder
+ ) where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Mason.Builder as B
+import qualified Mason.Builder.Internal as B
+import Network.Socket (Socket)
+import System.IO (Handle)
+
+data DynamicBackend = DynGrowingBuffer !B.GrowingBuffer
+ | DynChannel !B.Channel
+ | DynPutEnv !B.PutEnv
+
+instance B.Buildable DynamicBackend where
+ byteString bs = B.Builder $ \env buf -> case env of
+ DynGrowingBuffer e -> B.unBuilder (B.byteString bs) e buf
+ DynChannel e -> B.unBuilder (B.byteString bs) e buf
+ DynPutEnv e -> B.unBuilder (B.byteString bs) e buf
+ {-# INLINE byteString #-}
+ flush = B.Builder $ \env buf -> case env of
+ DynGrowingBuffer e -> B.unBuilder B.flush e buf
+ DynChannel e -> B.unBuilder B.flush e buf
+ DynPutEnv e -> B.unBuilder B.flush e buf
+ {-# INLINE flush #-}
+ allocate n = B.Builder $ \env buf -> case env of
+ DynGrowingBuffer e -> B.unBuilder (B.allocate n) e buf
+ DynChannel e -> B.unBuilder (B.allocate n) e buf
+ DynPutEnv e -> B.unBuilder (B.allocate n) e buf
+ {-# INLINE allocate #-}
+
+-- | Builder with a fixed set of backends. This helps reducing code size
+-- and unoptimised code especially on complex/recursive structures, at the cost of
+-- extensibility.
+type DynBuilder = B.BuilderFor DynamicBackend
+
+toStrictByteString :: DynBuilder -> B.ByteString
+toStrictByteString b = B.toStrictByteString $ B.Builder $ B.unBuilder b . DynGrowingBuffer
+{-# INLINE toStrictByteString #-}
+
+toLazyByteString :: DynBuilder -> BL.ByteString
+toLazyByteString b = B.toLazyByteString $ B.Builder $ B.unBuilder b . DynChannel
+{-# INLINE toLazyByteString #-}
+
+hPutBuilder :: Handle -> DynBuilder -> IO ()
+hPutBuilder h b = B.hPutBuilder h $ B.Builder $ B.unBuilder b . DynPutEnv
+{-# INLINE hPutBuilder #-}
+
+hPutBuilderLen :: Handle -> DynBuilder -> IO Int
+hPutBuilderLen h b = B.hPutBuilderLen h $ B.Builder $ B.unBuilder b . DynPutEnv
+{-# INLINE hPutBuilderLen #-}
+
+sendBuilder :: Socket -> DynBuilder -> IO Int
+sendBuilder h b = B.sendBuilder h $ B.Builder $ B.unBuilder b . DynPutEnv
+{-# INLINE sendBuilder #-}
diff --git a/src/Mason/Builder/Internal.hs b/src/Mason/Builder/Internal.hs
--- a/src/Mason/Builder/Internal.hs
+++ b/src/Mason/Builder/Internal.hs
@@ -1,593 +1,629 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-module Mason.Builder.Internal (Builder
- , BuilderFor(..)
- , BState
- , Buildable(..)
- , GrowingBuffer(..)
- , Buffer(..)
- , pattern Builder
- , unBuilder
- , byteStringCopy
- , shortByteString
- , StrictByteStringBackend
- , toStrictByteString
- , Channel(..)
- , LazyByteStringBackend
- , toLazyByteString
- , withPopper
- , StreamingBackend(..)
- , toStreamingBody
- , stringUtf8
- , lengthPrefixedWithin
- , primBounded
- , primFixed
- , primMapListFixed
- , primMapListBounded
- , primMapByteStringFixed
- , primMapLazyByteStringFixed
- , PutEnv(..)
- , BufferedIOBackend
- , hPutBuilderLen
- , encodeUtf8BuilderEscaped
- , sendBuilder
- , cstring
- , cstringUtf8
- , withPtr
- , storable
- , paddedBoundedPrim
- , zeroPaddedBoundedPrim
- -- * Internal
- , ensure
- , allocateConstant
- , withGrisu3
- , withGrisu3Rounded
- , roundDigit
- ) where
-
-import Control.Concurrent
-import Control.Exception (throw)
-import Control.Monad
-import Data.Bits ((.&.), shiftR)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Short.Internal as SB
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.Internal as BL
-import qualified Data.ByteString.Internal as B
-import qualified Data.ByteString.Builder as BB
-import qualified Data.ByteString.Builder.Prim as P
-import qualified Data.ByteString.Builder.Prim.Internal as B
-import Data.Text.Internal.Unsafe.Char (ord)
-import System.IO
-import Foreign.C.Types
-import Foreign.Ptr
-import Foreign.ForeignPtr.Unsafe
-import Foreign.ForeignPtr
-import Foreign.Marshal.Array (allocaArray)
-import Data.IORef
-import Data.Word (Word8)
-import Data.String
-import Foreign.Storable as S
-import System.IO.Unsafe
-import qualified Data.Text.Array as A
-import qualified Data.Text.Internal as T
-import qualified Data.Text.Internal.Encoding.Utf16 as U16
-import qualified Network.Socket as S
-import GHC.Prim (plusAddr#, indexWord8OffAddr#, RealWorld, Addr#, State# )
-import GHC.Ptr (Ptr(..))
-import GHC.Word (Word8(..))
-import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build, IO(..), unIO)
-
--- https://www.haskell.org/ghc/blog/20210607-the-keepAlive-story.html
-unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
-unsafeWithForeignPtr fo f = do
- r <- f (unsafeForeignPtrToPtr fo)
- touchForeignPtr fo
- return r
-
--- | The Builder type. Requires RankNTypes extension
-type Builder = forall s. Buildable s => BuilderFor s
-
--- | Builder specialised for a backend
-newtype BuilderFor s = RawBuilder { unRawBuilder :: s -> BState -> BState }
-
-unBuilder :: BuilderFor s -> s -> Buffer -> IO Buffer
-unBuilder (RawBuilder f) = \env (Buffer (Ptr ptr) (Ptr end)) -> IO (\s -> case f env (# ptr, end, s #) of
- (# ptr', end', s' #) -> (# s', Buffer (Ptr ptr') (Ptr end') #))
-{-# INLINE unBuilder #-}
-
-pattern Builder :: (s -> Buffer -> IO Buffer) -> BuilderFor s
-pattern Builder f <- (unBuilder -> f) where
- Builder f = RawBuilder $ \env (# ptr, end, s #) -> case unIO (f env (Buffer (Ptr ptr) (Ptr end))) s of
- (# s', Buffer (Ptr ptr') (Ptr end') #) -> (# ptr', end', s' #)
-
-{-# COMPLETE Builder #-}
-
-type BState = (#Addr#, Addr#, State# RealWorld #)
-
--- | This class is used to provide backend-specific operations for running a 'Builder'.
-class Buildable s where
- -- | Put a 'B.ByteString'.
- byteString :: B.ByteString -> BuilderFor s
- byteString = byteStringCopy
- {-# INLINE byteString #-}
- -- | Flush the content of the internal buffer.
- flush :: BuilderFor s
- -- | Allocate a buffer with at least the given length.
- allocate :: Int -> BuilderFor s
-
--- | Buffer pointers
-data Buffer = Buffer
- { bEnd :: {-# UNPACK #-} !(Ptr Word8) -- ^ end of the buffer (next to the last byte)
- , bCur :: {-# UNPACK #-} !(Ptr Word8) -- ^ current position
- }
-
--- | Copy a 'B.ByteString' to a buffer.
-byteStringCopy :: Buildable s => B.ByteString -> BuilderFor s
-byteStringCopy = \(B.PS fsrc ofs len) -> withPtr len $ \ptr -> do
- unsafeWithForeignPtr fsrc $ \src -> B.memcpy ptr (src `plusPtr` ofs) len
- return $ ptr `plusPtr` len
-{-# INLINE byteStringCopy #-}
-
--- | Copy a 'SB.ShortByteString' to a buffer.
-shortByteString :: SB.ShortByteString -> Builder
-shortByteString = \src -> let len = SB.length src in withPtr len $ \ptr ->
- plusPtr ptr len <$ SB.copyToPtr src 0 ptr len
-{-# INLINE shortByteString #-}
-
--- | Construct a 'Builder' from a "poke" function.
-withPtr :: Buildable s
- => Int -- ^ number of bytes to allocate (if needed)
- -> (Ptr Word8 -> IO (Ptr Word8)) -- ^ return a next pointer after writing
- -> BuilderFor s
-withPtr n f = ensure n $ \(Buffer e p) -> Buffer e <$> f p
-{-# INLINE withPtr #-}
-
--- | Turn a 'Storable' value into a 'Builder'
-storable :: Storable a => a -> Builder
-storable a = withPtr (sizeOf a) $ \p -> plusPtr p (sizeOf a) <$ poke (castPtr p) a
-{-# INLINE storable #-}
-
--- | Ensure that the given number of bytes is available in the buffer. Subject to semigroup fusion
-ensure :: Int -> (Buffer -> IO Buffer) -> Builder
-ensure mlen cont = Builder $ \env buf@(Buffer end ptr) ->
- if ptr `plusPtr` mlen >= end
- then do
- buf'@(Buffer end' ptr') <- unBuilder flush env buf
- if mlen <= minusPtr end' ptr'
- then cont buf'
- else unBuilder (allocate mlen) env buf' >>= cont
- else cont buf
-{-# INLINE[1] ensure #-}
-
-{-# RULES "<>/ensure" forall m n f g. ensure m f <> ensure n g = ensure (m + n) (f >=> g) #-}
-
--- | Run a builder within a buffer and prefix it by the length.
-lengthPrefixedWithin :: Int -- ^ maximum length
- -> B.BoundedPrim Int -- ^ prefix encoder
- -> BuilderFor () -> Builder
-lengthPrefixedWithin maxLen bp builder = ensure (B.sizeBound bp + maxLen) $ \(Buffer end origin) -> do
- let base = origin `plusPtr` B.sizeBound bp
- Buffer _ base' <- unBuilder builder () (Buffer end base)
- let len = minusPtr base' base
- newBase <- B.runB bp len origin
- c_memmove newBase base len
- return $ Buffer end (newBase `plusPtr` len)
-{-# INLINE lengthPrefixedWithin #-}
-
--- | Work with a constant buffer. 'allocate' will always fail.
-instance Buildable () where
- byteString = byteStringCopy
- {-# INLINE byteString #-}
- flush = mempty
- {-# INLINE flush #-}
- allocate _ = Builder $ \_ _ -> fail "Mason.Builder.Internal.allocate: can't allocate"
- {-# INLINE allocate #-}
-
-instance Semigroup (BuilderFor s) where
- RawBuilder f <> RawBuilder g = RawBuilder $ \e s -> g e (f e s)
- {-# INLINE[1] (<>) #-}
-
-instance Monoid (BuilderFor a) where
- mempty = RawBuilder (\_ s -> s)
- {-# INLINE mempty #-}
-
--- | UTF-8 encode a 'String'.
-stringUtf8 :: Buildable s => String -> BuilderFor s
-stringUtf8 = primMapListBounded P.charUtf8
-{-# INLINE [1] stringUtf8 #-}
-
-{-# RULES
-"stringUtf8/unpackCStringUtf8#" forall s.
- stringUtf8 (unpackCStringUtf8# s) = cstringUtf8 (Ptr s)
-
-"stringUtf8/unpackCString#" forall s.
- stringUtf8 (unpackCString# s) = cstring (Ptr s)
-
-"stringUtf8/unpackFoldrCString#" forall s.
- stringUtf8 (build (unpackFoldrCString# s)) = cstring (Ptr s)
- #-}
-
-cstring :: Ptr Word8 -> Builder
-cstring (Ptr addr0) = Builder $ step addr0
- where
- step addr env br@(Buffer end ptr)
- | W8# ch == 0 = pure br
- | ptr == end = unBuilder (ensure 3 $ step addr env) env br
- | otherwise = do
- S.poke ptr (W8# ch)
- let br' = Buffer end (ptr `plusPtr` 1)
- step (addr `plusAddr#` 1#) env br'
- where
- !ch = indexWord8OffAddr# addr 0#
-{-# INLINE cstring #-}
-
-cstringUtf8 :: Ptr Word8 -> Builder
-cstringUtf8 (Ptr addr0) = Builder $ step addr0
- where
- step addr env br@(Buffer end ptr)
- | W8# ch == 0 = pure br
- | ptr == end = unBuilder (ensure 3 $ step addr env) env br
- -- NULL is encoded as 0xc0 0x80
- | W8# ch == 0xc0
- , W8# (indexWord8OffAddr# addr 1#) == 0x80 = do
- S.poke ptr 0
- step (addr `plusAddr#` 2#) env (Buffer end (ptr `plusPtr` 1))
- | otherwise = do
- S.poke ptr (W8# ch)
- step (addr `plusAddr#` 1#) env (Buffer end (ptr `plusPtr` 1))
- where
- !ch = indexWord8OffAddr# addr 0#
-{-# INLINE cstringUtf8 #-}
-
-instance Buildable s => IsString (BuilderFor s) where
- fromString = stringUtf8
- {-# INLINE fromString #-}
-
--- | Use 'B.BoundedPrim'
-primBounded :: Buildable s => B.BoundedPrim a -> a -> BuilderFor s
-primBounded bp = withPtr (B.sizeBound bp) . B.runB bp
-{-# INLINE primBounded #-}
-
--- | Use 'B.FixedPrim'
-primFixed :: Buildable s => B.FixedPrim a -> a -> BuilderFor s
-primFixed fp a = withPtr (B.size fp) $ \ptr -> (ptr `plusPtr` B.size fp) <$ B.runF fp a ptr
-{-# INLINE primFixed #-}
-
-primMapListFixed :: (Foldable t, Buildable s) => B.FixedPrim a -> t a -> BuilderFor s
-primMapListFixed fp = foldMap (primFixed fp)
-{-# INLINE primMapListFixed #-}
-
-primMapListBounded :: Buildable s => B.BoundedPrim a -> [a] -> BuilderFor s
-primMapListBounded bp = foldMap (primBounded bp)
-{-# INLINE primMapListBounded #-}
-
-primMapByteStringFixed :: Buildable s => B.FixedPrim Word8 -> B.ByteString -> BuilderFor s
-primMapByteStringFixed fp = B.foldr (mappend . primFixed fp) mempty
-{-# INLINE primMapByteStringFixed #-}
-
-primMapLazyByteStringFixed :: Buildable s => B.FixedPrim Word8 -> BL.ByteString -> BuilderFor s
-primMapLazyByteStringFixed fp = BL.foldr (mappend . primFixed fp) mempty
-{-# INLINE primMapLazyByteStringFixed #-}
-
-paddedBoundedPrim
- :: Word8 -- ^ filler
- -> Int -- ^ pad if shorter than this
- -> B.BoundedPrim a
- -> a
- -> Builder
-paddedBoundedPrim ch size bp a = ensure (B.sizeBound bp) $ \(Buffer end ptr) -> do
- ptr' <- B.runB bp a ptr
- let len = ptr' `minusPtr` ptr
- let pad = size - len
- when (pad > 0) $ do
- c_memmove (ptr `plusPtr` pad) ptr len
- void $ B.memset ptr ch (fromIntegral pad)
- return $ Buffer end $ ptr' `plusPtr` max pad 0
-
-zeroPaddedBoundedPrim :: Int -> B.BoundedPrim a -> a -> Builder
-zeroPaddedBoundedPrim = paddedBoundedPrim 48
-
-newtype GrowingBuffer = GrowingBuffer (IORef (ForeignPtr Word8))
-
-instance Buildable GrowingBuffer where
- byteString = byteStringCopy
- {-# INLINE byteString #-}
- flush = mempty
- {-# INLINE flush #-}
- allocate len = Builder $ \(GrowingBuffer bufferRef) (Buffer _ dst) -> do
- fptr0 <- readIORef bufferRef
- let ptr0 = unsafeForeignPtrToPtr fptr0
- let !pos = dst `minusPtr` ptr0
- let !size' = pos + max len pos
- fptr <- mallocForeignPtrBytes size'
- let !dst' = unsafeForeignPtrToPtr fptr
- B.memcpy dst' ptr0 pos
- writeIORef bufferRef fptr
- return $ Buffer (dst' `plusPtr` size') (dst' `plusPtr` pos)
- {-# INLINE allocate #-}
-
-type StrictByteStringBackend = GrowingBuffer
-
--- | Create a strict 'B.ByteString'
-toStrictByteString :: BuilderFor StrictByteStringBackend -> B.ByteString
-toStrictByteString b = unsafePerformIO $ do
- fptr0 <- mallocForeignPtrBytes initialSize
- bufferRef <- newIORef fptr0
- let ptr0 = unsafeForeignPtrToPtr fptr0
-
- Buffer _ pos <- unBuilder b (GrowingBuffer bufferRef)
- $ Buffer (ptr0 `plusPtr` initialSize) ptr0
-
- fptr <- readIORef bufferRef
- pure $ B.PS fptr 0 (pos `minusPtr` unsafeForeignPtrToPtr fptr)
-
- where
- initialSize = 128
-{-# INLINE toStrictByteString #-}
-
-data Channel = Channel
- { chResp :: !(MVar B.ByteString)
- , chBuffer :: !(IORef (ForeignPtr Word8))
- }
-
-instance Buildable Channel where
- byteString bs
- | B.length bs < 4096 = byteStringCopy bs
- | otherwise = flush <> Builder (\(Channel v _) b -> b <$ putMVar v bs)
- {-# INLINE byteString #-}
- flush = Builder $ \(Channel v ref) (Buffer end ptr) -> do
- ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref
- let len = minusPtr ptr ptr0
- when (len > 0) $ do
- bs <- B.mallocByteString len
- unsafeWithForeignPtr bs $ \dst -> B.memcpy dst ptr0 len
- putMVar v $ B.PS bs 0 len
- return $! Buffer end ptr0
- {-# INLINE flush #-}
- allocate = allocateConstant chBuffer
- {-# INLINE allocate #-}
-
-type LazyByteStringBackend = Channel
-
--- | Create a lazy 'BL.ByteString'. Threaded runtime is required.
-toLazyByteString :: BuilderFor LazyByteStringBackend -> BL.ByteString
-toLazyByteString body = unsafePerformIO $ withPopper body $ \pop -> do
- let go _ = do
- bs <- pop
- return $! if B.null bs
- then BL.empty
- else BL.Chunk bs $ unsafePerformIO $ go ()
- return $ unsafePerformIO $ go ()
-{-# INLINE toLazyByteString #-}
-
--- | Use 'Builder' as a (IO B.ByteString -> IO a) -> IO a
-withPopper body cont = do
- resp <- newEmptyMVar
-
- let initialSize = 4080
- fptr <- mallocForeignPtrBytes initialSize
- ref <- newIORef fptr
- let ptr = unsafeForeignPtrToPtr fptr
-
- let final (Left e) = putMVar resp (throw e)
- final (Right _) = putMVar resp B.empty
- _ <- flip forkFinally final $ unBuilder (body <> flush) (Channel resp ref)
- $ Buffer (ptr `plusPtr` initialSize) ptr
-
- cont $ takeMVar resp
-{-# INLINE withPopper #-}
-
--- | Environment for handle output
-data PutEnv = PutEnv
- { peThreshold :: !Int
- , pePut :: !(Ptr Word8 -> Ptr Word8 -> IO ())
- -- ^ takes a pointer range and returns the number of bytes written
- , peBuffer :: !(IORef (ForeignPtr Word8))
- , peTotal :: !(IORef Int)
- }
-
--- | Allocate a new buffer.
-allocateConstant :: (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
-allocateConstant f len = Builder $ \env (Buffer _ _) -> do
- fptr <- mallocForeignPtrBytes len
- writeIORef (f env) fptr
- let ptr1 = unsafeForeignPtrToPtr fptr
- return $! Buffer (ptr1 `plusPtr` len) ptr1
-{-# INLINE allocateConstant #-}
-
-instance Buildable PutEnv where
- byteString bs@(B.PS fptr ofs len) = Builder $ \env@PutEnv{..} buf -> if len > peThreshold
- then do
- buf' <- unBuilder flush env buf
- unsafeWithForeignPtr fptr $ \ptr -> do
- let ptr0 = ptr `plusPtr` ofs
- pePut ptr0 (ptr0 `plusPtr` len)
- pure buf'
- else unBuilder (byteStringCopy bs) env buf
- {-# INLINE byteString #-}
-
- flush = Builder $ \PutEnv{..} (Buffer end ptr) -> do
- ptr0 <- unsafeForeignPtrToPtr <$> readIORef peBuffer
- let len = minusPtr ptr ptr0
- modifyIORef' peTotal (+len)
- pePut ptr0 ptr
- return $! Buffer end ptr0
- {-# INLINE flush #-}
-
- allocate = allocateConstant peBuffer
- {-# INLINE allocate #-}
-
-type BufferedIOBackend = PutEnv
-
--- | Write a 'Builder' into a handle and obtain the number of bytes written.
--- 'flush' does not imply actual disk operations. Set 'NoBuffering' if you want
--- it to write the content immediately.
-hPutBuilderLen :: Handle -> BuilderFor BufferedIOBackend -> IO Int
-hPutBuilderLen h b = do
- let initialSize = 4096
- fptr <- mallocForeignPtrBytes initialSize
- ref <- newIORef fptr
- let ptr = unsafeForeignPtrToPtr fptr
- counter <- newIORef 0
- _ <- unBuilder (b <> flush)
- (PutEnv initialSize (\ptr0 ptr1 -> hPutBuf h ptr (minusPtr ptr1 ptr0)) ref counter)
- (Buffer (ptr `plusPtr` initialSize) ptr)
- readIORef counter
-{-# INLINE hPutBuilderLen #-}
-
-sendBufRange :: S.Socket -> Ptr Word8 -> Ptr Word8 -> IO ()
-sendBufRange sock ptr0 ptr1 = go ptr0 where
- go p
- | p >= ptr1 = return ()
- | otherwise = do
- sent <- S.sendBuf sock p (minusPtr ptr1 p)
- S.withFdSocket sock $ threadWaitWrite . fromIntegral
- when (sent > 0) $ go $ p `plusPtr` sent
-
--- | Write a 'Builder' into a handle and obtain the number of bytes written.
-sendBuilder :: S.Socket -> BuilderFor BufferedIOBackend -> IO Int
-sendBuilder sock b = do
- let initialSize = 4096
- fptr <- mallocForeignPtrBytes initialSize
- ref <- newIORef fptr
- let ptr = unsafeForeignPtrToPtr fptr
- counter <- newIORef 0
- _ <- unBuilder (b <> flush)
- (PutEnv initialSize (sendBufRange sock) ref counter)
- (Buffer (ptr `plusPtr` initialSize) ptr)
- readIORef counter
-{-# INLINE sendBuilder #-}
-
-{-# INLINE encodeUtf8BuilderEscaped #-}
-
--- | Encode 'T.Text' with a custom escaping function
-encodeUtf8BuilderEscaped :: Buildable s => B.BoundedPrim Word8 -> T.Text -> BuilderFor s
-encodeUtf8BuilderEscaped be = step where
- bound = max 4 $ B.sizeBound be
-
- step (T.Text arr off len) = Builder $ loop off where
- iend = off + len
- loop !i0 env !br@(Buffer ope op0)
- | i0 >= iend = return br
- | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)
- | otherwise = unBuilder (ensure bound (loop i0 env)) env br
- where
- outRemaining = (ope `minusPtr` op0) `div` bound
- inpRemaining = iend - i0
-
- goPartial !iendTmp = go i0 op0
- where
- go !i !op
- | i < iendTmp = case A.unsafeIndex arr i of
- w | w <= 0x7F -> do
- B.runB be (fromIntegral w) op >>= go (i + 1)
- | w <= 0x7FF -> do
- poke8 0 $ (w `shiftR` 6) + 0xC0
- poke8 1 $ (w .&. 0x3f) + 0x80
- go (i + 1) (op `plusPtr` 2)
- | 0xD800 <= w && w <= 0xDBFF -> do
- let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))
- poke8 0 $ (c `shiftR` 18) + 0xF0
- poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80
- poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80
- poke8 3 $ (c .&. 0x3F) + 0x80
- go (i + 2) (op `plusPtr` 4)
- | otherwise -> do
- poke8 0 $ (w `shiftR` 12) + 0xE0
- poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80
- poke8 2 $ (w .&. 0x3F) + 0x80
- go (i + 1) (op `plusPtr` 3)
- | otherwise = loop i env (Buffer ope op)
- where
- poke8 :: Integral a => Int -> a -> IO ()
- poke8 j v = S.poke (op `plusPtr` j) (fromIntegral v :: Word8)
-
-foreign import ccall unsafe "memmove"
- c_memmove :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
-
--- | Decimal encoding of a positive 'Double'.
-{-# INLINE withGrisu3 #-}
-withGrisu3 :: Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
-withGrisu3 d contFail cont = allocaArray 2 $ \plen -> allocaArray 19 $ \ptr -> do
- let pexp = plusPtr plen (S.sizeOf (undefined :: CInt))
- success <- c_grisu3 (realToFrac d) (ptr `plusPtr` 1) plen pexp
- if success == 0
- then contFail
- else do
- len <- fromIntegral <$> S.peek plen
- e <- fromIntegral <$> S.peek pexp
- cont ptr len (len + e)
-
-{-# INLINE withGrisu3Rounded #-}
-withGrisu3Rounded :: Int -> Double -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
-withGrisu3Rounded prec val cont = withGrisu3 val (error "withGrisu3Rounded: failed") $ \ptr len e -> do
- let len' = min prec len
- bump <- roundDigit prec len ptr
- if bump then cont ptr len' (e + 1) else cont (ptr `plusPtr` 1) len' e
-
--- | Round up to the supplied precision inplace.
-roundDigit
- :: Int -- ^ precision
- -> Int -- ^ available digits
- -> Ptr Word8 -- ^ content
- -> IO Bool
-roundDigit prec len _ | prec >= len = pure False
-roundDigit prec _ ptr = do
- rd <- peekElemOff ptr (prec + 1)
- let carry 0 = do
- poke ptr 49
- pure True
- carry i = do
- d <- peekElemOff ptr i
- if d == 57
- then pokeElemOff ptr i 48 *> carry (i - 1)
- else do
- pokeElemOff ptr i (d + 1)
- pure False
- if rd >= 53
- then carry prec
- else pure False
-
-foreign import ccall unsafe "static grisu3"
- c_grisu3 :: CDouble -> Ptr Word8 -> Ptr CInt -> Ptr CInt -> IO CInt
-
-data StreamingBackend = StreamingBackend
- { sePush :: !(B.ByteString -> IO ())
- , seBuffer :: !(IORef (ForeignPtr Word8))
- }
-
-instance Buildable StreamingBackend where
- byteString bs
- | B.length bs < 4096 = byteStringCopy bs
- | otherwise = flush <> Builder (\env b -> b <$ sePush env bs)
- {-# INLINE byteString #-}
- flush = Builder $ \(StreamingBackend push ref) (Buffer end ptr) -> do
- ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref
- let len = minusPtr ptr ptr0
- when (len > 0) $ push $! B.unsafeCreate len $ \dst -> B.memcpy dst ptr0 len
- return $! Buffer end ptr0
- {-# INLINE flush #-}
- allocate = allocateConstant seBuffer
- {-# INLINE allocate #-}
-
--- | Convert a 'Builder' into a .
-toStreamingBody :: BuilderFor StreamingBackend -> (BB.Builder -> IO ()) -> IO () -> IO ()
-toStreamingBody body = \write _ -> do
- let initialSize = 4080
- fptr <- mallocForeignPtrBytes initialSize
- ref <- newIORef fptr
- let ptr = unsafeForeignPtrToPtr fptr
- Buffer _ ptr2 <- unBuilder body
- (StreamingBackend (write . BB.byteString) ref)
- (Buffer (ptr `plusPtr` initialSize) ptr)
- fptr' <- readIORef ref
- let ptr1 = unsafeForeignPtrToPtr fptr'
- write $ BB.byteString $ B.PS fptr' 0 (minusPtr ptr2 ptr1)
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
+module Mason.Builder.Internal (Builder
+ , BuilderFor(..)
+ , BState
+ , Buildable(..)
+ , GrowingBuffer(..)
+ , Buffer(..)
+ , pattern Builder
+ , unBuilder
+ , byteStringCopy
+ , shortByteString
+ , StrictByteStringBackend
+ , toStrictByteString
+ , Channel(..)
+ , LazyByteStringBackend
+ , toLazyByteString
+ , withPopper
+ , StreamingBackend(..)
+ , toStreamingBody
+ , stringUtf8
+ , lengthPrefixedWithin
+ , primBounded
+ , primFixed
+ , primMapListFixed
+ , primMapListBounded
+ , primMapByteStringFixed
+ , primMapLazyByteStringFixed
+ , PutEnv(..)
+ , BufferedIOBackend
+ , hPutBuilderLen
+ , encodeUtf8BuilderEscaped
+ , sendBuilder
+ , cstring
+ , cstringUtf8
+ , withPtr
+ , storable
+ , paddedBoundedPrim
+ , zeroPaddedBoundedPrim
+ -- * Internal
+ , ensure
+ , allocateConstant
+ , withGrisu3
+ , withGrisu3Rounded
+ , roundDigit
+ ) where
+
+import Control.Concurrent
+import Control.Exception (throw)
+import Control.Monad
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Short.Internal as SB
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Internal as BL
+import qualified Data.ByteString.Internal as B
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Builder.Prim as P
+import qualified Data.ByteString.Builder.Prim.Internal as B
+import System.IO
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.ForeignPtr.Unsafe
+import Foreign.ForeignPtr
+import Foreign.Marshal.Array (allocaArray)
+import Data.IORef
+import Data.Word (Word8)
+import Data.String
+import Foreign.Storable as S
+import System.IO.Unsafe
+import qualified Data.Text.Array as A
+import qualified Data.Text.Internal as T
+import qualified Network.Socket as S
+import GHC.Prim (plusAddr#, indexWord8OffAddr#, RealWorld, Addr#, State# )
+import GHC.Ptr (Ptr(..))
+import GHC.Word (Word8(..))
+import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build, IO(..), unIO)
+
+#if MIN_VERSION_text(2,0,0)
+#else
+-- imports required by 'encodeUtf8BuilderEscaped'
+import Data.Bits ((.&.), shiftR)
+import Data.Text.Internal.Unsafe.Char (ord)
+import qualified Data.Text.Internal.Encoding.Utf16 as U16
+#endif
+
+-- https://www.haskell.org/ghc/blog/20210607-the-keepAlive-story.html
+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+unsafeWithForeignPtr fo f = do
+ r <- f (unsafeForeignPtrToPtr fo)
+ touchForeignPtr fo
+ return r
+
+-- | The Builder type. Requires RankNTypes extension
+type Builder = forall s. Buildable s => BuilderFor s
+
+-- | Builder specialised for a backend
+newtype BuilderFor s = RawBuilder { unRawBuilder :: s -> BState -> BState }
+
+unBuilder :: BuilderFor s -> s -> Buffer -> IO Buffer
+unBuilder (RawBuilder f) = \env (Buffer (Ptr ptr) (Ptr end)) -> IO (\s -> case f env (# ptr, end, s #) of
+ (# ptr', end', s' #) -> (# s', Buffer (Ptr ptr') (Ptr end') #))
+{-# INLINE unBuilder #-}
+
+pattern Builder :: (s -> Buffer -> IO Buffer) -> BuilderFor s
+pattern Builder f <- (unBuilder -> f) where
+ Builder f = RawBuilder $ \env (# ptr, end, s #) -> case unIO (f env (Buffer (Ptr ptr) (Ptr end))) s of
+ (# s', Buffer (Ptr ptr') (Ptr end') #) -> (# ptr', end', s' #)
+
+{-# COMPLETE Builder #-}
+
+type BState = (#Addr#, Addr#, State# RealWorld #)
+
+-- | This class is used to provide backend-specific operations for running a 'Builder'.
+class Buildable s where
+ -- | Put a 'B.ByteString'.
+ byteString :: B.ByteString -> BuilderFor s
+ byteString = byteStringCopy
+ {-# INLINE byteString #-}
+ -- | Flush the content of the internal buffer.
+ flush :: BuilderFor s
+ -- | Allocate a buffer with at least the given length.
+ allocate :: Int -> BuilderFor s
+
+-- | Buffer pointers
+data Buffer = Buffer
+ { bEnd :: {-# UNPACK #-} !(Ptr Word8) -- ^ end of the buffer (next to the last byte)
+ , bCur :: {-# UNPACK #-} !(Ptr Word8) -- ^ current position
+ }
+
+-- | Copy a 'B.ByteString' to a buffer.
+byteStringCopy :: Buildable s => B.ByteString -> BuilderFor s
+byteStringCopy = \(B.PS fsrc ofs len) -> withPtr len $ \ptr -> do
+ unsafeWithForeignPtr fsrc $ \src -> B.memcpy ptr (src `plusPtr` ofs) len
+ return $ ptr `plusPtr` len
+{-# INLINE byteStringCopy #-}
+
+-- | Copy a 'SB.ShortByteString' to a buffer.
+shortByteString :: SB.ShortByteString -> Builder
+shortByteString = \src -> let len = SB.length src in withPtr len $ \ptr ->
+ plusPtr ptr len <$ SB.copyToPtr src 0 ptr len
+{-# INLINE shortByteString #-}
+
+-- | Construct a 'Builder' from a "poke" function.
+withPtr :: Buildable s
+ => Int -- ^ number of bytes to allocate (if needed)
+ -> (Ptr Word8 -> IO (Ptr Word8)) -- ^ return a next pointer after writing
+ -> BuilderFor s
+withPtr n f = ensure n $ \(Buffer e p) -> Buffer e <$> f p
+{-# INLINE withPtr #-}
+
+-- | Turn a 'Storable' value into a 'Builder'
+storable :: Storable a => a -> Builder
+storable a = withPtr (sizeOf a) $ \p -> plusPtr p (sizeOf a) <$ poke (castPtr p) a
+{-# INLINE storable #-}
+
+-- | Ensure that the given number of bytes is available in the buffer. Subject to semigroup fusion
+ensure :: Int -> (Buffer -> IO Buffer) -> Builder
+ensure mlen cont = Builder $ \env buf@(Buffer end ptr) ->
+ if ptr `plusPtr` mlen >= end
+ then do
+ buf'@(Buffer end' ptr') <- unBuilder flush env buf
+ if mlen <= minusPtr end' ptr'
+ then cont buf'
+ else unBuilder (allocate mlen) env buf' >>= cont
+ else cont buf
+{-# INLINE[1] ensure #-}
+
+{-# RULES "<>/ensure" forall m n f g. ensure m f <> ensure n g = ensure (m + n) (f >=> g) #-}
+
+-- | Run a builder within a buffer and prefix it by the length.
+lengthPrefixedWithin :: Int -- ^ maximum length
+ -> B.BoundedPrim Int -- ^ prefix encoder
+ -> BuilderFor () -> Builder
+lengthPrefixedWithin maxLen bp builder = ensure (B.sizeBound bp + maxLen) $ \(Buffer end origin) -> do
+ let base = origin `plusPtr` B.sizeBound bp
+ Buffer _ base' <- unBuilder builder () (Buffer end base)
+ let len = minusPtr base' base
+ newBase <- B.runB bp len origin
+ c_memmove newBase base len
+ return $ Buffer end (newBase `plusPtr` len)
+{-# INLINE lengthPrefixedWithin #-}
+
+-- | Work with a constant buffer. 'allocate' will always fail.
+instance Buildable () where
+ byteString = byteStringCopy
+ {-# INLINE byteString #-}
+ flush = mempty
+ {-# INLINE flush #-}
+ allocate _ = Builder $ \_ _ -> fail "Mason.Builder.Internal.allocate: can't allocate"
+ {-# INLINE allocate #-}
+
+instance Semigroup (BuilderFor s) where
+ RawBuilder f <> RawBuilder g = RawBuilder $ \e s -> g e (f e s)
+ {-# INLINE[1] (<>) #-}
+
+instance Monoid (BuilderFor a) where
+ mempty = RawBuilder (\_ s -> s)
+ {-# INLINE mempty #-}
+
+-- | UTF-8 encode a 'String'.
+stringUtf8 :: Buildable s => String -> BuilderFor s
+stringUtf8 = primMapListBounded P.charUtf8
+{-# INLINE [1] stringUtf8 #-}
+
+{-# RULES
+"stringUtf8/unpackCStringUtf8#" forall s.
+ stringUtf8 (unpackCStringUtf8# s) = cstringUtf8 (Ptr s)
+
+"stringUtf8/unpackCString#" forall s.
+ stringUtf8 (unpackCString# s) = cstring (Ptr s)
+
+"stringUtf8/unpackFoldrCString#" forall s.
+ stringUtf8 (build (unpackFoldrCString# s)) = cstring (Ptr s)
+ #-}
+
+cstring :: Ptr Word8 -> Builder
+cstring (Ptr addr0) = Builder $ step addr0
+ where
+ step addr env br@(Buffer end ptr)
+ | W8# ch == 0 = pure br
+ | ptr == end = unBuilder (ensure 3 $ step addr env) env br
+ | otherwise = do
+ S.poke ptr (W8# ch)
+ let br' = Buffer end (ptr `plusPtr` 1)
+ step (addr `plusAddr#` 1#) env br'
+ where
+ !ch = indexWord8OffAddr# addr 0#
+{-# INLINE cstring #-}
+
+cstringUtf8 :: Ptr Word8 -> Builder
+cstringUtf8 (Ptr addr0) = Builder $ step addr0
+ where
+ step addr env br@(Buffer end ptr)
+ | W8# ch == 0 = pure br
+ | ptr == end = unBuilder (ensure 3 $ step addr env) env br
+ -- NULL is encoded as 0xc0 0x80
+ | W8# ch == 0xc0
+ , W8# (indexWord8OffAddr# addr 1#) == 0x80 = do
+ S.poke ptr 0
+ step (addr `plusAddr#` 2#) env (Buffer end (ptr `plusPtr` 1))
+ | otherwise = do
+ S.poke ptr (W8# ch)
+ step (addr `plusAddr#` 1#) env (Buffer end (ptr `plusPtr` 1))
+ where
+ !ch = indexWord8OffAddr# addr 0#
+{-# INLINE cstringUtf8 #-}
+
+instance Buildable s => IsString (BuilderFor s) where
+ fromString = stringUtf8
+ {-# INLINE fromString #-}
+
+-- | Use 'B.BoundedPrim'
+primBounded :: Buildable s => B.BoundedPrim a -> a -> BuilderFor s
+primBounded bp = withPtr (B.sizeBound bp) . B.runB bp
+{-# INLINE primBounded #-}
+
+-- | Use 'B.FixedPrim'
+primFixed :: Buildable s => B.FixedPrim a -> a -> BuilderFor s
+primFixed fp a = withPtr (B.size fp) $ \ptr -> (ptr `plusPtr` B.size fp) <$ B.runF fp a ptr
+{-# INLINE primFixed #-}
+
+primMapListFixed :: (Foldable t, Buildable s) => B.FixedPrim a -> t a -> BuilderFor s
+primMapListFixed fp = foldMap (primFixed fp)
+{-# INLINE primMapListFixed #-}
+
+primMapListBounded :: Buildable s => B.BoundedPrim a -> [a] -> BuilderFor s
+primMapListBounded bp = foldMap (primBounded bp)
+{-# INLINE primMapListBounded #-}
+
+primMapByteStringFixed :: Buildable s => B.FixedPrim Word8 -> B.ByteString -> BuilderFor s
+primMapByteStringFixed fp = B.foldr (mappend . primFixed fp) mempty
+{-# INLINE primMapByteStringFixed #-}
+
+primMapLazyByteStringFixed :: Buildable s => B.FixedPrim Word8 -> BL.ByteString -> BuilderFor s
+primMapLazyByteStringFixed fp = BL.foldr (mappend . primFixed fp) mempty
+{-# INLINE primMapLazyByteStringFixed #-}
+
+paddedBoundedPrim
+ :: Word8 -- ^ filler
+ -> Int -- ^ pad if shorter than this
+ -> B.BoundedPrim a
+ -> a
+ -> Builder
+paddedBoundedPrim ch size bp a = ensure (B.sizeBound bp) $ \(Buffer end ptr) -> do
+ ptr' <- B.runB bp a ptr
+ let len = ptr' `minusPtr` ptr
+ let pad = size - len
+ when (pad > 0) $ do
+ c_memmove (ptr `plusPtr` pad) ptr len
+ void $ B.memset ptr ch (fromIntegral pad)
+ return $ Buffer end $ ptr' `plusPtr` max pad 0
+
+zeroPaddedBoundedPrim :: Int -> B.BoundedPrim a -> a -> Builder
+zeroPaddedBoundedPrim = paddedBoundedPrim 48
+
+newtype GrowingBuffer = GrowingBuffer (IORef (ForeignPtr Word8))
+
+instance Buildable GrowingBuffer where
+ byteString = byteStringCopy
+ {-# INLINE byteString #-}
+ flush = mempty
+ {-# INLINE flush #-}
+ allocate len = Builder $ \(GrowingBuffer bufferRef) (Buffer _ dst) -> do
+ fptr0 <- readIORef bufferRef
+ let ptr0 = unsafeForeignPtrToPtr fptr0
+ let !pos = dst `minusPtr` ptr0
+ let !size' = pos + max len pos
+ fptr <- mallocForeignPtrBytes size'
+ let !dst' = unsafeForeignPtrToPtr fptr
+ B.memcpy dst' ptr0 pos
+ writeIORef bufferRef fptr
+ return $ Buffer (dst' `plusPtr` size') (dst' `plusPtr` pos)
+ {-# INLINE allocate #-}
+
+type StrictByteStringBackend = GrowingBuffer
+
+-- | Create a strict 'B.ByteString'
+toStrictByteString :: BuilderFor StrictByteStringBackend -> B.ByteString
+toStrictByteString b = unsafePerformIO $ do
+ fptr0 <- mallocForeignPtrBytes initialSize
+ bufferRef <- newIORef fptr0
+ let ptr0 = unsafeForeignPtrToPtr fptr0
+
+ Buffer _ pos <- unBuilder b (GrowingBuffer bufferRef)
+ $ Buffer (ptr0 `plusPtr` initialSize) ptr0
+
+ fptr <- readIORef bufferRef
+ pure $ B.PS fptr 0 (pos `minusPtr` unsafeForeignPtrToPtr fptr)
+
+ where
+ initialSize = 128
+{-# INLINE toStrictByteString #-}
+
+data Channel = Channel
+ { chResp :: !(MVar B.ByteString)
+ , chBuffer :: !(IORef (ForeignPtr Word8))
+ }
+
+instance Buildable Channel where
+ byteString bs
+ | B.length bs < 4096 = byteStringCopy bs
+ | otherwise = flush <> Builder (\(Channel v _) b -> b <$ putMVar v bs)
+ {-# INLINE byteString #-}
+ flush = Builder $ \(Channel v ref) (Buffer end ptr) -> do
+ ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref
+ let len = minusPtr ptr ptr0
+ when (len > 0) $ do
+ bs <- B.mallocByteString len
+ unsafeWithForeignPtr bs $ \dst -> B.memcpy dst ptr0 len
+ putMVar v $ B.PS bs 0 len
+ return $! Buffer end ptr0
+ {-# INLINE flush #-}
+ allocate = allocateConstant chBuffer
+ {-# INLINE allocate #-}
+
+type LazyByteStringBackend = Channel
+
+-- | Create a lazy 'BL.ByteString'. Threaded runtime is required.
+toLazyByteString :: BuilderFor LazyByteStringBackend -> BL.ByteString
+toLazyByteString body = unsafePerformIO $ withPopper body $ \pop -> do
+ let go _ = do
+ bs <- pop
+ return $! if B.null bs
+ then BL.empty
+ else BL.Chunk bs $ unsafePerformIO $ go ()
+ return $ unsafePerformIO $ go ()
+{-# INLINE toLazyByteString #-}
+
+-- | Use 'Builder' as a (IO B.ByteString -> IO a) -> IO a
+withPopper body cont = do
+ resp <- newEmptyMVar
+
+ let initialSize = 4080
+ fptr <- mallocForeignPtrBytes initialSize
+ ref <- newIORef fptr
+ let ptr = unsafeForeignPtrToPtr fptr
+
+ let final (Left e) = putMVar resp (throw e)
+ final (Right _) = putMVar resp B.empty
+ _ <- flip forkFinally final $ unBuilder (body <> flush) (Channel resp ref)
+ $ Buffer (ptr `plusPtr` initialSize) ptr
+
+ cont $ takeMVar resp
+{-# INLINE withPopper #-}
+
+-- | Environment for handle output
+data PutEnv = PutEnv
+ { peThreshold :: !Int
+ , pePut :: !(Ptr Word8 -> Ptr Word8 -> IO ())
+ -- ^ takes a pointer range and returns the number of bytes written
+ , peBuffer :: !(IORef (ForeignPtr Word8))
+ , peTotal :: !(IORef Int)
+ }
+
+-- | Allocate a new buffer.
+allocateConstant :: (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s
+allocateConstant f len = Builder $ \env (Buffer _ _) -> do
+ fptr <- mallocForeignPtrBytes len
+ writeIORef (f env) fptr
+ let ptr1 = unsafeForeignPtrToPtr fptr
+ return $! Buffer (ptr1 `plusPtr` len) ptr1
+{-# INLINE allocateConstant #-}
+
+instance Buildable PutEnv where
+ byteString bs@(B.PS fptr ofs len) = Builder $ \env@PutEnv{..} buf -> if len > peThreshold
+ then do
+ buf' <- unBuilder flush env buf
+ unsafeWithForeignPtr fptr $ \ptr -> do
+ let ptr0 = ptr `plusPtr` ofs
+ pePut ptr0 (ptr0 `plusPtr` len)
+ pure buf'
+ else unBuilder (byteStringCopy bs) env buf
+ {-# INLINE byteString #-}
+
+ flush = Builder $ \PutEnv{..} (Buffer end ptr) -> do
+ ptr0 <- unsafeForeignPtrToPtr <$> readIORef peBuffer
+ let len = minusPtr ptr ptr0
+ modifyIORef' peTotal (+len)
+ pePut ptr0 ptr
+ return $! Buffer end ptr0
+ {-# INLINE flush #-}
+
+ allocate = allocateConstant peBuffer
+ {-# INLINE allocate #-}
+
+type BufferedIOBackend = PutEnv
+
+-- | Write a 'Builder' into a handle and obtain the number of bytes written.
+-- 'flush' does not imply actual disk operations. Set 'NoBuffering' if you want
+-- it to write the content immediately.
+hPutBuilderLen :: Handle -> BuilderFor BufferedIOBackend -> IO Int
+hPutBuilderLen h b = do
+ let initialSize = 4096
+ fptr <- mallocForeignPtrBytes initialSize
+ ref <- newIORef fptr
+ let ptr = unsafeForeignPtrToPtr fptr
+ counter <- newIORef 0
+ _ <- unBuilder (b <> flush)
+ (PutEnv initialSize (\ptr0 ptr1 -> hPutBuf h ptr (minusPtr ptr1 ptr0)) ref counter)
+ (Buffer (ptr `plusPtr` initialSize) ptr)
+ readIORef counter
+{-# INLINE hPutBuilderLen #-}
+
+sendBufRange :: S.Socket -> Ptr Word8 -> Ptr Word8 -> IO ()
+sendBufRange sock ptr0 ptr1 = go ptr0 where
+ go p
+ | p >= ptr1 = return ()
+ | otherwise = do
+ sent <- S.sendBuf sock p (minusPtr ptr1 p)
+ S.withFdSocket sock $ threadWaitWrite . fromIntegral
+ when (sent > 0) $ go $ p `plusPtr` sent
+
+-- | Write a 'Builder' into a handle and obtain the number of bytes written.
+sendBuilder :: S.Socket -> BuilderFor BufferedIOBackend -> IO Int
+sendBuilder sock b = do
+ let initialSize = 4096
+ fptr <- mallocForeignPtrBytes initialSize
+ ref <- newIORef fptr
+ let ptr = unsafeForeignPtrToPtr fptr
+ counter <- newIORef 0
+ _ <- unBuilder (b <> flush)
+ (PutEnv initialSize (sendBufRange sock) ref counter)
+ (Buffer (ptr `plusPtr` initialSize) ptr)
+ readIORef counter
+{-# INLINE sendBuilder #-}
+
+{-# INLINE encodeUtf8BuilderEscaped #-}
+
+-- | Encode 'T.Text' with a custom escaping function.
+--
+-- Note that implementation differs between @text-1.x@ and @text-2.x@ due to the
+-- package moving from using UTF-16 to UTF-8 for the internal representation.
+encodeUtf8BuilderEscaped :: Buildable s => B.BoundedPrim Word8 -> T.Text -> BuilderFor s
+
+#if MIN_VERSION_text(2,0,0)
+encodeUtf8BuilderEscaped be = step where
+ bound = max 4 $ B.sizeBound be
+
+ step (T.Text arr off len) = Builder $ loop off where
+ iend = off + len
+ loop !i0 env !br@(Buffer ope op0)
+ | i0 >= iend = return br
+ | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)
+ | otherwise = unBuilder (ensure bound (loop i0 env)) env br
+ where
+ outRemaining = (ope `minusPtr` op0) `quot` bound
+ inpRemaining = iend - i0
+
+ goPartial !iendTmp = go i0 op0
+ where
+ go !i !op
+ | i < iendTmp = do
+ let w = A.unsafeIndex arr i
+ if w < 0x80
+ then B.runB be w op >>= go (i + 1)
+ else poke op w >> go (i + 1) (op `plusPtr` 1)
+ | otherwise = loop i env (Buffer ope op)
+
+#else
+encodeUtf8BuilderEscaped be = step where
+ bound = max 4 $ B.sizeBound be
+
+ step (T.Text arr off len) = Builder $ loop off where
+ iend = off + len
+ loop !i0 env !br@(Buffer ope op0)
+ | i0 >= iend = return br
+ | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)
+ | otherwise = unBuilder (ensure bound (loop i0 env)) env br
+ where
+ outRemaining = (ope `minusPtr` op0) `div` bound
+ inpRemaining = iend - i0
+
+ goPartial !iendTmp = go i0 op0
+ where
+ go !i !op
+ | i < iendTmp = case A.unsafeIndex arr i of
+ w | w <= 0x7F -> do
+ B.runB be (fromIntegral w) op >>= go (i + 1)
+ | w <= 0x7FF -> do
+ poke8 0 $ (w `shiftR` 6) + 0xC0
+ poke8 1 $ (w .&. 0x3f) + 0x80
+ go (i + 1) (op `plusPtr` 2)
+ | 0xD800 <= w && w <= 0xDBFF -> do
+ let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))
+ poke8 0 $ (c `shiftR` 18) + 0xF0
+ poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80
+ poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80
+ poke8 3 $ (c .&. 0x3F) + 0x80
+ go (i + 2) (op `plusPtr` 4)
+ | otherwise -> do
+ poke8 0 $ (w `shiftR` 12) + 0xE0
+ poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80
+ poke8 2 $ (w .&. 0x3F) + 0x80
+ go (i + 1) (op `plusPtr` 3)
+ | otherwise = loop i env (Buffer ope op)
+ where
+ poke8 :: Integral a => Int -> a -> IO ()
+ poke8 j v = S.poke (op `plusPtr` j) (fromIntegral v :: Word8)
+#endif
+
+foreign import ccall unsafe "memmove"
+ c_memmove :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
+
+-- | Decimal encoding of a positive 'Double'.
+{-# INLINE withGrisu3 #-}
+withGrisu3 :: Double -> IO r -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
+withGrisu3 d contFail cont = allocaArray 2 $ \plen -> allocaArray 19 $ \ptr -> do
+ let pexp = plusPtr plen (S.sizeOf (undefined :: CInt))
+ success <- c_grisu3 (realToFrac d) (ptr `plusPtr` 1) plen pexp
+ if success == 0
+ then contFail
+ else do
+ len <- fromIntegral <$> S.peek plen
+ e <- fromIntegral <$> S.peek pexp
+ cont ptr len (len + e)
+
+{-# INLINE withGrisu3Rounded #-}
+withGrisu3Rounded :: Int -> Double -> (Ptr Word8 -> Int -> Int -> IO r) -> IO r
+withGrisu3Rounded prec val cont = withGrisu3 val (error "withGrisu3Rounded: failed") $ \ptr len e -> do
+ let len' = min prec len
+ bump <- roundDigit prec len ptr
+ if bump then cont ptr len' (e + 1) else cont (ptr `plusPtr` 1) len' e
+
+-- | Round up to the supplied precision inplace.
+roundDigit
+ :: Int -- ^ precision
+ -> Int -- ^ available digits
+ -> Ptr Word8 -- ^ content
+ -> IO Bool
+roundDigit prec len _ | prec >= len = pure False
+roundDigit prec _ ptr = do
+ rd <- peekElemOff ptr (prec + 1)
+ let carry 0 = do
+ poke ptr 49
+ pure True
+ carry i = do
+ d <- peekElemOff ptr i
+ if d == 57
+ then pokeElemOff ptr i 48 *> carry (i - 1)
+ else do
+ pokeElemOff ptr i (d + 1)
+ pure False
+ if rd >= 53
+ then carry prec
+ else pure False
+
+foreign import ccall unsafe "static grisu3"
+ c_grisu3 :: CDouble -> Ptr Word8 -> Ptr CInt -> Ptr CInt -> IO CInt
+
+data StreamingBackend = StreamingBackend
+ { sePush :: !(B.ByteString -> IO ())
+ , seBuffer :: !(IORef (ForeignPtr Word8))
+ }
+
+instance Buildable StreamingBackend where
+ byteString bs
+ | B.length bs < 4096 = byteStringCopy bs
+ | otherwise = flush <> Builder (\env b -> b <$ sePush env bs)
+ {-# INLINE byteString #-}
+ flush = Builder $ \(StreamingBackend push ref) (Buffer end ptr) -> do
+ ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref
+ let len = minusPtr ptr ptr0
+ when (len > 0) $ push $! B.unsafeCreate len $ \dst -> B.memcpy dst ptr0 len
+ return $! Buffer end ptr0
+ {-# INLINE flush #-}
+ allocate = allocateConstant seBuffer
+ {-# INLINE allocate #-}
+
+-- | Convert a 'Builder' into a .
+toStreamingBody :: BuilderFor StreamingBackend -> (BB.Builder -> IO ()) -> IO () -> IO ()
+toStreamingBody body = \write _ -> do
+ let initialSize = 4080
+ fptr <- mallocForeignPtrBytes initialSize
+ ref <- newIORef fptr
+ let ptr = unsafeForeignPtrToPtr fptr
+ Buffer _ ptr2 <- unBuilder body
+ (StreamingBackend (write . BB.byteString) ref)
+ (Buffer (ptr `plusPtr` initialSize) ptr)
+ fptr' <- readIORef ref
+ let ptr1 = unsafeForeignPtrToPtr fptr'
+ write $ BB.byteString $ B.PS fptr' 0 (minusPtr ptr2 ptr1)