mason 0.2.5 → 0.2.6
raw patch · 7 files changed
+1813/−1777 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +36/−36
- README.md +194/−194
- mason.cabal +39/−39
- src/Mason/Builder.hs +760/−760
- src/Mason/Builder/Compat.hs +92/−92
- src/Mason/Builder/Dynamic.hs +63/−63
- src/Mason/Builder/Internal.hs +629/−593
CHANGELOG.md view
@@ -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.
README.md view
@@ -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)--<details>-<summary>Click to expand</summary>-<pre>-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 )-</pre>-</details>--* [haskell-perf/strict-bytestring-builder](https://github.com/haskell-perf/strict-bytestring-builders)--<details>-<summary>Click to expand</summary>-<pre>-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 )-</pre>-</details>--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) + +<details> +<summary>Click to expand</summary> +<pre> +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 ) +</pre> +</details> + +* [haskell-perf/strict-bytestring-builder](https://github.com/haskell-perf/strict-bytestring-builders) + +<details> +<summary>Click to expand</summary> +<pre> +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 ) +</pre> +</details> + +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.cabal view
@@ -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
src/Mason/Builder.hs view
@@ -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 <fumiexcel@gmail.com>---------------------------------------------------------------------------------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 <https://github.com/stoklund/varint#prefixvarint PrefixVarInt>-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 <fumiexcel@gmail.com> +-- +---------------------------------------------------------------------------- +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 <https://github.com/stoklund/varint#prefixvarint PrefixVarInt> +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 #-}
src/Mason/Builder/Compat.hs view
@@ -1,93 +1,93 @@-------------------------------------------------------------------------------- |--- Module : Mason.Builder.Compat--- Copyright : (c) Fumiaki Kinoshita 2020---- License : BSD3------ Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>------ 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 <fumiexcel@gmail.com> +-- +-- 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
src/Mason/Builder/Dynamic.hs view
@@ -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 #-}
src/Mason/Builder/Internal.hs view
@@ -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 <http://hackage.haskell.org/package/http-client-0.7.1/docs/Network-HTTP-Client.html#t:GivesPopper GivesPopper'-withPopper :: BuilderFor LazyByteStringBackend -> (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 <http://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:StreamingBody StreamingBody>.-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 <http://hackage.haskell.org/package/http-client-0.7.1/docs/Network-HTTP-Client.html#t:GivesPopper GivesPopper' +withPopper :: BuilderFor LazyByteStringBackend -> (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 <http://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:StreamingBody StreamingBody>. +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)