packages feed

text-builder-linear 0.1 → 0.1.1

raw patch · 17 files changed

+878/−489 lines, 17 filesdep ~basedep ~bytestringdep ~quote-quot

Dependency ranges changed: base, bytestring, quote-quot, tasty, tasty-bench, tasty-quickcheck, text

Files

README.md view
@@ -1,8 +1,8 @@-# linear-builder [![Hackage](http://img.shields.io/hackage/v/linear-builder.svg)](https://hackage.haskell.org/package/linear-builder) [![Stackage LTS](http://stackage.org/package/linear-builder/badge/lts)](http://stackage.org/lts/package/linear-builder) [![Stackage Nightly](http://stackage.org/package/linear-builder/badge/nightly)](http://stackage.org/nightly/package/linear-builder)+# text-builder-linear [![Hackage](http://img.shields.io/hackage/v/text-builder-linear.svg)](https://hackage.haskell.org/package/text-builder-linear) [![Stackage LTS](http://stackage.org/package/text-builder-linear/badge/lts)](http://stackage.org/lts/package/text-builder-linear) [![Stackage Nightly](http://stackage.org/package/text-builder-linear/badge/nightly)](http://stackage.org/nightly/package/text-builder-linear)  _Linear types for linear times!_ -Builder for strict `Text`, based on linear types. It's consistently+Builder for strict `Text` and `ByteString`, based on linear types. It consistently outperforms lazy `Builder` from `text` as well as a strict builder from `text-builder`, and scales better. @@ -52,50 +52,136 @@ significantly faster than `Data.Text.Lazy.Builder`, as witnessed by benchmarks for `blaze-builder` below. -## Benchmarks+## Case study -|Group / size|`text`|`text-builder`|Ratio|This package|Ratio|+Let's benchmark builders, which concatenate all `Char` from `minBound` to `maxBound`, producing a large `Text`:++```haskell+#!/usr/bin/env cabal+{- cabal:+build-depends: base, tasty-bench, text, text-builder, text-builder-linear+ghc-options: -O2+-}++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Text.Builder as TB+import qualified Data.Text.Builder.Linear as TBL+import System.Environment (getArgs)+import Test.Tasty.Bench++mkBench :: Monoid a => String -> (Char -> a) -> (a -> Int) -> Benchmark+mkBench s f g = bench s $ nf (g . foldMap f . enumFromTo minBound) maxBound+{-# INLINE mkBench #-}++main :: IO ()+main = defaultMain+  [ mkBench "text, lazy" TLB.singleton (fromIntegral . TL.length . TLB.toLazyText)+  , mkBench "text, strict" TLB.singleton (T.length . TL.toStrict . TLB.toLazyText)+  , mkBench "text-builder" TB.char (T.length . TB.run)+  , mkBench "text-builder-linear" TBL.fromChar (T.length . TBL.runBuilder)+  ]+```++Running this program with `cabal run Main.hs -- +RTS -T` yields following results:++```+text, lazy:+  4.25 ms ± 107 μs,  11 MB allocated, 912 B  copied+text, strict:+  7.18 ms ± 235 μs,  24 MB allocated,  10 MB copied+text-builder:+  80.1 ms ± 3.0 ms, 218 MB allocated, 107 MB copied+text-builder-linear:+  5.37 ms ± 146 μs,  44 MB allocated,  78 KB copied+```++The first result seems the best both in time and memory and corresponds to the+usual `Text` builder, where we do not materialize the entire result at all.+It builds chunks of lazy `Text` lazily and consumes them at once by+`TL.length`. Thus there are 11 MB of allocations in nursery, none of which+survive generation 0 garbage collector, so nothing is copied.++The second result is again the usual `Text` builder, but emulates a strict+consumer: we materialize a strict `Text` before computing length. Allocation+are doubled, and half of them (corresponding to the strict `Text`) survive to+the heap. Time is also almost twice longer, but still quite good.++The third result is for `text-builder` and demonstrates how bad things could+go with strict builders, aiming to precompute the precise length of the+buffer: allocating a thunk per char is tremendously slow and expensive.++The last result corresponds to the current package. We generate a strict+`Text` by growing and reallocating the buffer, thus allocations are quite+high. Nevertheless, it is already faster than the usual `Text` builder with+strict consumer and does not strain the garbage collector.++Things get very different if we remove `{-# INLINE mkBench #-}`:++```+text, lazy:+  36.9 ms ± 599 μs, 275 MB allocated,  30 KB copied+text, strict:+  44.7 ms ± 1.3 ms, 287 MB allocated,  25 MB copied+text-builder:+  77.6 ms ± 2.2 ms, 218 MB allocated, 107 MB copied+text-builder-linear:+  5.35 ms ± 212 μs,  44 MB allocated,  79 KB copied+```++Builders from `text` package degrade rapidly, 6-8x slower and 10-20x more+allocations. That's because their constant factors rely crucially on+everything getting inlined, which makes their performance fragile and+unreliable in large-scale applications. On the bright side of things, our+builder remains as fast as before and now is a clear champion.++## Benchmarks for `Text`++Measured with GHC 9.6 on aarch64:++|Group / size|`text`|`text-builder`|  |This package|  | |------------|-----:|-------------:|-:|-----------:|-:| | **Text** ||||||-|1|69.2 ns|37.0 ns|0.53x|36.8 ns|0.53x|-|10|736 ns|344 ns|0.47x|190 ns|0.26x|-|100|7.07 μs|3.42 μs|0.48x|1.81 μs|0.26x|-|1000|74.2 μs|38.5 μs|0.52x|14.4 μs|0.19x|-|10000|1.10 ms|477 μs|0.43x|163 μs|0.15x|-|100000|23.1 ms|11.6 ms|0.50x|4.17 ms|0.18x|-|1000000|282 ms|166 ms|0.59x|40.4 ms|0.14x|+|1|47.4 ns|24.2 ns|0.51x|35.2 ns|0.74x|+|10|509 ns|195 ns|0.38x|197 ns|0.39x|+|100|4.94 μs|1.74 μs|0.35x|1.66 μs|0.34x|+|1000|52.6 μs|17.0 μs|0.32x|15.0 μs|0.28x|+|10000|646 μs|206 μs|0.32x|155 μs|0.24x|+|100000|12.2 ms|3.34 ms|0.27x|2.60 ms|0.21x|+|1000000|159 ms|55.3 ms|0.35x|16.1 ms|0.10x| | **Char** ||||||-|1|83.2 ns|34.8 ns|0.42x|34.8 ns|0.42x|-|10|378 ns|302 ns|0.80x|123 ns|0.33x|-|100|3.14 μs|2.46 μs|0.78x|922 ns|0.29x|-|1000|34.9 μs|31.3 μs|0.90x|9.37 μs|0.27x|-|10000|494 μs|454 μs|0.92x|101 μs|0.20x|-|100000|15.9 ms|13.8 ms|0.87x|1.64 ms|0.10x|-|1000000|212 ms|227 ms|1.07x|14.5 ms|0.07x|+|1|46.9 ns|21.1 ns|0.45x|22.3 ns|0.48x|+|10|229 ns|152 ns|0.66x|79.9 ns|0.35x|+|100|2.00 μs|1.23 μs|0.61x|618 ns|0.31x|+|1000|21.9 μs|10.3 μs|0.47x|6.28 μs|0.29x|+|10000|285 μs|153 μs|0.54x|68.5 μs|0.24x|+|100000|7.70 ms|4.08 ms|0.53x|992 μs|0.13x|+|1000000|110 ms|106 ms|0.96x|9.19 ms|0.08x| | **Decimal** ||||||-|1|147 ns|993 ns|6.76x|106 ns|0.72x|-|10|1.36 μs|10.1 μs|7.43x|845 ns|0.62x|-|100|13.5 μs|108 μs|7.97x|8.44 μs|0.62x|-|1000|136 μs|1.34 ms|9.84x|83.0 μs|0.61x|-|10000|1.85 ms|22.0 ms|11.86x|822 μs|0.44x|-|100000|33.9 ms|237 ms|7.00x|10.4 ms|0.31x|-|1000000|399 ms|2.504 s|6.28x|89.8 ms|0.23x|+|1|97.7 ns|872 ns|8.92x|80.2 ns|0.82x|+|10|864 ns|8.72 μs|10.09x|684 ns|0.79x|+|100|9.07 μs|93.5 μs|10.32x|7.25 μs|0.80x|+|1000|92.4 μs|1.06 ms|11.44x|67.5 μs|0.73x|+|10000|1.13 ms|13.4 ms|11.88x|667 μs|0.59x|+|100000|18.7 ms|141 ms|7.57x|7.57 ms|0.41x|+|1000000|229 ms|1.487 s|6.48x|67.8 ms|0.30x| | **Hexadecimal** ||||||-|1|599 ns|940 ns|1.57x|98.9 ns|0.17x|-|10|6.05 μs|9.89 μs|1.64x|916 ns|0.15x|-|100|66.4 μs|121 μs|1.82x|9.61 μs|0.14x|-|1000|807 μs|1.47 ms|1.82x|96.7 μs|0.12x|-|10000|13.0 ms|20.8 ms|1.60x|980 μs|0.08x|-|100000|152 ms|223 ms|1.47x|11.7 ms|0.08x|-|1000000|1.657 s|2.228 s|1.34x|104 ms|0.06x|+|1|403 ns|749 ns|1.86x|43.9 ns|0.11x|+|10|3.94 μs|7.66 μs|1.94x|308 ns|0.08x|+|100|42.8 μs|89.0 μs|2.08x|2.88 μs|0.07x|+|1000|486 μs|986 μs|2.03x|27.7 μs|0.06x|+|10000|7.10 ms|12.6 ms|1.77x|283 μs|0.04x|+|100000|80.1 ms|133 ms|1.65x|3.53 ms|0.04x|+|1000000|867 ms|1.340 s|1.55x|28.9 ms|0.03x| | **Double** ||||||-|1|11.9 μs|26.6 μs|2.23x|632 ns|0.05x|-|10|117 μs|270 μs|2.30x|6.32 μs|0.05x|-|100|1.20 ms|3.68 ms|3.06x|64.5 μs|0.05x|-|1000|12.8 ms|43.9 ms|3.44x|638 μs|0.05x|-|10000|126 ms|457 ms|3.63x|7.38 ms|0.06x|-|100000|1.266 s|4.717 s|3.73x|65.9 ms|0.05x|-|1000000|12.599 s|65.467 s|5.20x|653 ms|0.05x|+|1|7.56 μs|18.3 μs|2.42x|414 ns|0.05x|+|10|76.5 μs|188 μs|2.46x|4.23 μs|0.06x|+|100|754 μs|2.35 ms|3.11x|44.4 μs|0.06x|+|1000|7.94 ms|25.8 ms|3.25x|436 μs|0.05x|+|10000|79.1 ms|285 ms|3.60x|4.90 ms|0.06x|+|100000|796 ms|2.938 s|3.69x|45.1 ms|0.06x|+|1000000|8.003 s|32.411 s|4.05x|436 ms|0.05x|  If you are not convinced by synthetic data, here are benchmarks for@@ -117,3 +203,57 @@ customAttribute   1.68 ms ± 135 μs, 56% less than baseline ```++## Benchmarks for `ByteString`++Somewhat surprisingly, `text-builder-linear` now offers rendering to strict `ByteString`+as well. It is consistently faster than `bytestring` when a string gets over 32k+(which is `defaultChunkSize` for `bytestring` builder). For mid-sized strings+`bytestring` is slightly faster in certain disciplines, mostly by virtue of using+`cbits` via FFI, while this package remains 100% native Haskell.++Benchmarks below were measured with GHC 9.6 on aarch64 and include comparison+to [`bytestring-strict-builder`](https://hackage.haskell.org/package/bytestring-strict-builder):++|Group / size|`bytestring`|`…-strict-builder`|  |This package|  |+|------------|-----------:|-----------------:|-:|-----------:|-:|+| **Text** ||||||+|1|106 ns|33.5 ns|0.32x|35.2 ns|0.33x|+|10|322 ns|217 ns|0.68x|197 ns|0.61x|+|100|2.49 μs|1.89 μs|0.76x|1.66 μs|0.67x|+|1000|21.8 μs|18.5 μs|0.85x|15.0 μs|0.69x|+|10000|231 μs|212 μs|0.92x|155 μs|0.67x|+|100000|3.97 ms|3.54 ms|0.89x|2.60 ms|0.66x|+|1000000|81.2 ms|51.5 ms|0.63x|16.1 ms|0.20x|+| **Char** ||||||+|1|99.0 ns|19.4 ns|0.20x|22.3 ns|0.23x|+|10|270 ns|82.9 ns|0.31x|79.9 ns|0.30x|+|100|1.77 μs|723 ns|0.41x|618 ns|0.35x|+|1000|20.4 μs|8.37 μs|0.41x|6.28 μs|0.31x|+|10000|322 μs|129 μs|0.40x|68.5 μs|0.21x|+|100000|10.4 ms|2.50 ms|0.24x|992 μs|0.10x|+|1000000|143 ms|67.4 ms|0.47x|9.19 ms|0.06x|+| **Decimal** ||||||+|1|152 ns|174 ns|1.14x|80.2 ns|0.53x|+|10|685 ns|1.55 μs|2.26x|684 ns|1.00x|+|100|5.88 μs|17.2 μs|2.93x|7.25 μs|1.23x|+|1000|60.3 μs|196 μs|3.25x|67.5 μs|1.12x|+|10000|648 μs|4.25 ms|6.57x|667 μs|1.03x|+|100000|11.2 ms|62.8 ms|5.62x|7.57 ms|0.68x|+|1000000|150 ms|655 ms|4.37x|67.8 ms|0.45x|+| **Hexadecimal** ||||||+|1|94.7 ns|||43.9 ns|0.46x|+|10|255 ns|||308 ns|1.21x|+|100|1.72 μs|||2.88 μs|1.67x|+|1000|18.9 μs|||27.7 μs|1.46x|+|10000|250 μs|||283 μs|1.13x|+|100000|6.94 ms|||3.53 ms|0.51x|+|1000000|93.2 ms|||28.9 ms|0.31x|+| **Double** ||||||+|1|457 ns|||414 ns|0.91x|+|10|3.94 μs|||4.23 μs|1.07x|+|100|40.3 μs|||44.4 μs|1.10x|+|1000|398 μs|||436 μs|1.10x|+|10000|5.65 ms|||4.90 ms|0.87x|+|100000|63.3 ms|||45.1 ms|0.71x|+|1000000|673 ms|||436 ms|0.65x|
bench/BenchChar.hs view
@@ -5,6 +5,8 @@  module BenchChar (benchChar) where +import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B import Data.Char import qualified Data.Text as T import Data.Text.Builder.Linear.Buffer@@ -16,12 +18,22 @@ import qualified Text.Builder #endif +#ifdef MIN_VERSION_bytestring_strict_builder+import qualified ByteString.StrictBuilder+#endif+ benchLazyBuilder ∷ Int → T.Text benchLazyBuilder = toStrict . toLazyText . go mempty   where     go !acc 0 = acc     go !acc n = let ch = chr n in go (singleton ch <> (acc <> singleton ch)) (n - 1) +benchLazyBuilderBS ∷ Int → B.ByteString+benchLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty+  where+    go !acc 0 = acc+    go !acc n = let ch = chr n in go (B.charUtf8 ch <> (acc <> B.charUtf8 ch)) (n - 1)+ #ifdef MIN_VERSION_text_builder benchStrictBuilder ∷ Int → T.Text benchStrictBuilder = Text.Builder.run . go mempty@@ -30,6 +42,14 @@     go !acc n = let ch = chr n in go (Text.Builder.char ch <> (acc <> Text.Builder.char ch)) (n - 1) #endif +#ifdef MIN_VERSION_bytestring_strict_builder+benchStrictBuilderBS ∷ Int → B.ByteString+benchStrictBuilderBS = ByteString.StrictBuilder.builderBytes . go mempty+  where+    go !acc 0 = acc+    go !acc n = let ch = chr n in go (ByteString.StrictBuilder.utf8Char ch <> (acc <> ByteString.StrictBuilder.utf8Char ch)) (n - 1)+#endif+ benchLinearBuilder ∷ Int → T.Text benchLinearBuilder m = runBuffer (\b → go b m)   where@@ -43,8 +63,12 @@ mkGroup :: Int → Benchmark mkGroup n = bgroup (show n)   [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n+  , bench "Data.ByteString.Builder" $ nf benchLazyBuilderBS n #ifdef MIN_VERSION_text_builder   , bench "Text.Builder" $ nf benchStrictBuilder n+#endif+#ifdef MIN_VERSION_bytestring_strict_builder+  , bench "ByteString.StrictBuilder" $ nf benchStrictBuilderBS n #endif   , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n   ]
bench/BenchDecimal.hs view
@@ -5,6 +5,8 @@  module BenchDecimal (benchDecimal) where +import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B import qualified Data.Text as T import Data.Text.Builder.Linear.Buffer import Data.Text.Lazy (toStrict)@@ -16,6 +18,10 @@ import qualified Text.Builder #endif +#ifdef MIN_VERSION_bytestring_strict_builder+import qualified ByteString.StrictBuilder+#endif+ int :: Int int = 123456789123456789 @@ -25,6 +31,12 @@     go !acc 0 = acc     go !acc n = let i = n * int in go (decimal i <> (acc <> decimal i)) (n - 1) +benchLazyBuilderBS ∷ Int → B.ByteString+benchLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty+  where+    go !acc 0 = acc+    go !acc n = let i = n * int in go (B.intDec i <> (acc <> B.intDec i)) (n - 1)+ #ifdef MIN_VERSION_text_builder benchStrictBuilder ∷ Int → T.Text benchStrictBuilder = Text.Builder.run . go mempty@@ -33,6 +45,14 @@     go !acc n = let i = n * int in go (Text.Builder.decimal i <> (acc <> Text.Builder.decimal i)) (n - 1) #endif +#ifdef MIN_VERSION_bytestring_strict_builder+benchStrictBuilderBS ∷ Int → B.ByteString+benchStrictBuilderBS = ByteString.StrictBuilder.builderBytes . go mempty+  where+    go !acc 0 = acc+    go !acc n = let i = n * int in go (ByteString.StrictBuilder.asciiIntegral i <> (acc <> ByteString.StrictBuilder.asciiIntegral i)) (n - 1)+#endif+ benchLinearBuilder ∷ Int → T.Text benchLinearBuilder m = runBuffer (\b → go b m)   where@@ -46,8 +66,12 @@ mkGroup :: Int → Benchmark mkGroup n = bgroup (show n)   [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n+  , bench "Data.ByteString.Builder" $ nf benchLazyBuilderBS n #ifdef MIN_VERSION_text_builder   , bench "Text.Builder" $ nf benchStrictBuilder n+#endif+#ifdef MIN_VERSION_bytestring_strict_builder+  , bench "ByteString.StrictBuilder" $ nf benchStrictBuilderBS n #endif   , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n   ]
bench/BenchDouble.hs view
@@ -5,6 +5,8 @@  module BenchDouble (benchDouble) where +import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B import qualified Data.Text as T import Data.Text.Builder.Linear.Buffer import Data.Text.Lazy (toStrict)@@ -25,6 +27,12 @@     go !acc 0 = acc     go !acc n = let d = fromIntegral n * dbl in go (realFloat d <> (acc <> realFloat d)) (n - 1) +benchLazyBuilderBS ∷ Int → B.ByteString+benchLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty+  where+    go !acc 0 = acc+    go !acc n = let d = fromIntegral n * dbl in go (B.doubleDec d <> (acc <> B.doubleDec d)) (n - 1)+ #ifdef MIN_VERSION_text_builder benchStrictBuilder ∷ Int → T.Text benchStrictBuilder = Text.Builder.run . go mempty@@ -46,6 +54,7 @@ mkGroup :: Int → Benchmark mkGroup n = bgroup (show n)   [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n+  , bench "Data.ByteString.Builder" $ nf benchLazyBuilderBS n #ifdef MIN_VERSION_text_builder   , bench "Text.Builder" $ nf benchStrictBuilder n #endif
bench/BenchHexadecimal.hs view
@@ -5,6 +5,8 @@  module BenchHexadecimal (benchHexadecimal) where +import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B import qualified Data.Text as T import Data.Text.Builder.Linear.Buffer import Data.Text.Lazy (toStrict)@@ -25,6 +27,12 @@     go !acc 0 = acc     go !acc n = let i = fromIntegral n * word in go (hexadecimal i <> (acc <> hexadecimal i)) (n - 1) +benchLazyBuilderBS ∷ Int → B.ByteString+benchLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty+  where+    go !acc 0 = acc+    go !acc n = go (B.wordHex (fromIntegral n) <> (acc <> B.wordHex (fromIntegral n))) (n - 1)+ #ifdef MIN_VERSION_text_builder benchStrictBuilder ∷ Int → T.Text benchStrictBuilder = Text.Builder.run . go mempty@@ -46,6 +54,7 @@ mkGroup :: Int → Benchmark mkGroup n = bgroup (show n)   [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n+  , bench "Data.ByteString.Builder" $ nf benchLazyBuilderBS n #ifdef MIN_VERSION_text_builder   , bench "Text.Builder" $ nf benchStrictBuilder n #endif
bench/BenchText.hs view
@@ -5,7 +5,10 @@  module BenchText (benchText) where +import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Text.Builder.Linear.Buffer import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText, fromText)@@ -15,6 +18,10 @@ import qualified Text.Builder #endif +#ifdef MIN_VERSION_bytestring_strict_builder+import qualified ByteString.StrictBuilder+#endif+ txt ∷ T.Text txt = T.pack "Haskell + Linear Types = ♡" @@ -25,6 +32,13 @@     go !acc 0 = acc     go !acc n = go (txtB <> (acc <> txtB)) (n - 1) +benchLazyBuilderBS ∷ Int → B.ByteString+benchLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty+  where+    txtB = B.byteString $ T.encodeUtf8 txt+    go !acc 0 = acc+    go !acc n = go (txtB <> (acc <> txtB)) (n - 1)+ #ifdef MIN_VERSION_text_builder benchStrictBuilder ∷ Int → T.Text benchStrictBuilder = Text.Builder.run . go mempty@@ -34,6 +48,15 @@     go !acc n = go (txtB <> (acc <> txtB)) (n - 1) #endif +#ifdef MIN_VERSION_bytestring_strict_builder+benchStrictBuilderBS ∷ Int → B.ByteString+benchStrictBuilderBS = ByteString.StrictBuilder.builderBytes . go mempty+  where+    txtB = ByteString.StrictBuilder.bytes $ T.encodeUtf8 txt+    go !acc 0 = acc+    go !acc n = go (txtB <> (acc <> txtB)) (n - 1)+#endif+ benchLinearBuilder ∷ Int → T.Text benchLinearBuilder m = runBuffer (\b → go b m)   where@@ -47,8 +70,12 @@ mkGroup :: Int → Benchmark mkGroup n = bgroup (show n)   [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n+  , bench "Data.ByteString.Builder" $ nf benchLazyBuilderBS n #ifdef MIN_VERSION_text_builder   , bench "Text.Builder" $ nf benchStrictBuilder n+#endif+#ifdef MIN_VERSION_bytestring_strict_builder+  , bench "ByteString.StrictBuilder" $ nf benchStrictBuilderBS n #endif   , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n   ]
bench/Main.hs view
@@ -5,11 +5,8 @@  module Main where -import Data.Foldable (foldl') import Test.Tasty.Bench-import Test.Tasty.Runners (TestTree(..)) import Test.Tasty.Patterns.Printer-import Test.Tasty.Patterns.Types as Pat  import BenchChar import BenchDecimal@@ -18,7 +15,7 @@ import BenchText  main ∷ IO ()-main = defaultMain $ map (mapLeafs addCompare) $+main = defaultMain $ map (mapLeafBenchmarks addCompare) $   [ benchText   , benchChar   , benchDecimal@@ -31,22 +28,5 @@  addCompare :: ([String] -> Benchmark -> Benchmark) addCompare (name : path)-  | name /= textBenchName = bcompare (printAwkExpr (locateLeaf (textBenchName : path)))+  | name /= textBenchName = bcompare (printAwkExpr (locateBenchmark (textBenchName : path))) addCompare _ = id--mapLeafs :: ([String] -> Benchmark -> Benchmark) -> Benchmark -> Benchmark-mapLeafs processLeaf = go mempty-  where-    go :: [String] -> Benchmark -> Benchmark-    go path = \case-      SingleTest name t    -> processLeaf (name : path) (SingleTest name t)-      TestGroup name tts   -> TestGroup name (map (go (name : path)) tts)-      PlusTestOptions g tt -> PlusTestOptions g (go path tt)-      WithResource res f   -> WithResource res (go path . f)-      AskOptions f         -> AskOptions (go path . f)-      After dep expr tt    -> After dep expr (go path tt)--locateLeaf :: [String] -> Expr-locateLeaf path-  = foldl' And (IntLit 1)-  $ zipWith (\i name -> Pat.EQ (Field (Sub NF (IntLit i))) (StringLit name)) [0..] path
changelog.md view
@@ -1,3 +1,11 @@+## 0.1.1++* Introduce `ByteString` backend (thanks @oberblastmeister for the idea).+* Fix decimal builder for 30- and 31-bit wide types.+* Speed up decimal builder on aarch64.+* Speed up hexadecimal builder.+* Support 32-bit architectures.+ ## 0.1  * Initial release.
src/Data/Text/Builder/Linear.hs view
@@ -3,25 +3,26 @@ -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com> ----- Builder for strict 'Text', based on linear types. It's consistently+-- Builder for strict 'Text' and 'ByteString', based on linear types. It consistently -- outperforms "Data.Text.Lazy.Builder" -- from @text@ as well as a strict builder from @text-builder@, -- and scales better.--module Data.Text.Builder.Linear-  ( Builder(..)-  , runBuilder-  , fromText-  , fromChar-  , fromAddr-  , fromDec-  , fromHex-  , fromDouble-  ) where+module Data.Text.Builder.Linear (+  Builder (..),+  runBuilder,+  runBuilderBS,+  fromText,+  fromChar,+  fromAddr,+  fromDec,+  fromHex,+  fromDouble,+) where  import Data.Bits (FiniteBits)-import Data.Text.Internal (Text(..))-import GHC.Exts (IsString(..), Addr#)+import Data.ByteString.Internal (ByteString (..))+import Data.Text.Internal (Text (..))+import GHC.Exts (Addr#, IsString (..))  import Data.Text.Builder.Linear.Buffer @@ -37,10 +38,9 @@ -- Note that (similar to other builders) concatenation of 'Builder's allocates -- thunks. This is to a certain extent mitigated by aggressive inlining, -- but it is faster to use 'Buffer' directly.----newtype Builder = Builder { unBuilder :: Buffer ⊸ Buffer }+newtype Builder = Builder {unBuilder ∷ Buffer ⊸ Buffer} --- | Run 'Builder' computation on an empty 'Buffer', returning 'Text'.+-- | Run 'Builder' computation on an empty 'Buffer', returning strict 'Text'. -- -- >>> :set -XOverloadedStrings -XMagicHash -- >>> runBuilder (fromText "foo" <> fromChar '_' <> fromAddr "bar"#)@@ -48,11 +48,15 @@ -- -- This function has a polymorphic arrow and thus can be used both in -- usual and linear contexts.----runBuilder :: forall m. Builder %m → Text+runBuilder ∷ ∀ m. Builder %m → Text runBuilder (Builder f) = runBuffer f {-# INLINE runBuilder #-} +-- | Same as 'runBuilder', but returning a UTF-8 encoded strict 'ByteString'.+runBuilderBS ∷ ∀ m. Builder %m → ByteString+runBuilderBS (Builder f) = runBufferBS f+{-# INLINE runBuilderBS #-}+ instance Show Builder where   show (Builder f) = show (runBuffer f) @@ -73,8 +77,7 @@ -- >>> :set -XOverloadedStrings -- >>> fromText "foo" <> fromText "bar" -- "foobar"----fromText :: Text → Builder+fromText ∷ Text → Builder fromText x = Builder $ \b → b |> x {-# INLINE fromText #-} @@ -83,7 +86,9 @@ -- >>> fromChar 'x' <> fromChar 'y' -- "xy" ---fromChar :: Char → Builder+-- In contrast to 'Data.Text.Lazy.Builder.singleton', it's a responsibility+-- of the caller to sanitize surrogate code points with 'Data.Text.Internal.safe'.+fromChar ∷ Char → Builder fromChar x = Builder $ \b → b |>. x {-# INLINE fromChar #-} @@ -93,35 +98,34 @@ -- >>> fromAddr "foo"# <> fromAddr "bar"# -- "foobar" ---fromAddr :: Addr# → Builder+-- The literal string must not contain zero bytes @\\0@ and must be a valid UTF-8,+-- these conditions are not checked.+fromAddr ∷ Addr# → Builder fromAddr x = Builder $ \b → b |># x {-# INLINE fromAddr #-} --- | Create 'Builder', containing decimal representation of a given number.+-- | Create 'Builder', containing decimal representation of a given integer. -- -- >>> fromChar 'x' <> fromDec (123 :: Int) -- "x123"----fromDec :: (Integral a, FiniteBits a) => a → Builder+fromDec ∷ (Integral a, FiniteBits a) ⇒ a → Builder fromDec x = Builder $ \b → b |>$ x {-# INLINE fromDec #-} --- | Create 'Builder', containing hexadecimal representation of a given number.+-- | Create 'Builder', containing hexadecimal representation of a given integer. -- -- >>> :set -XMagicHash -- >>> fromAddr "0x"# <> fromHex (0x123def :: Int) -- "0x123def"----fromHex :: (Integral a, FiniteBits a) => a → Builder+fromHex ∷ (Integral a, FiniteBits a) ⇒ a → Builder fromHex x = Builder $ \b → b |>& x {-# INLINE fromHex #-} --- | Create 'Builder', containing a given 'Double'.+-- | Create 'Builder', containing decimal representation of a given 'Double'. -- -- >>> :set -XMagicHash -- >>> fromAddr "pi="# <> fromDouble pi -- "pi=3.141592653589793"----fromDouble :: Double → Builder+fromDouble ∷ Double → Builder fromDouble x = Builder $ \b → b |>% x {-# INLINE fromDouble #-}
src/Data/Text/Builder/Linear/Buffer.hs view
@@ -4,35 +4,35 @@ -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com> -- -- 'Buffer' for strict 'Text', based on linear types.--module Data.Text.Builder.Linear.Buffer-  ( Buffer-  , runBuffer-  , dupBuffer-  , consumeBuffer-  , eraseBuffer-  , foldlIntoBuffer-  , (|>)-  , (|>.)-  , (|>#)-  , (<|)-  , (.<|)-  , (<|#)-  , (><)-  , (|>$)-  , ($<|)-  , (|>%)-  , (%<|)-  , (|>&)-  , (&<|)-  , (|>…)-  , (…<|)-  ) where+module Data.Text.Builder.Linear.Buffer (+  Buffer,+  runBuffer,+  runBufferBS,+  dupBuffer,+  consumeBuffer,+  eraseBuffer,+  foldlIntoBuffer,+  (|>),+  (|>.),+  (|>#),+  (<|),+  (.<|),+  (<|#),+  (><),+  (|>$),+  ($<|),+  (|>%),+  (%<|),+  (|>&),+  (&<|),+  (|>…),+  (…<|),+) where -import qualified Data.Text.Array as A-import Data.Text.Internal (Text(..))-import GHC.Exts (cstringLength#, Addr#, Int(..), Ptr(..), setByteArray#)-import GHC.ST (ST(..))+import Data.Text.Array qualified as A+import Data.Text.Internal (Text (..))+import GHC.Exts (Addr#, Int (..), Ptr (..), cstringLength#, setByteArray#)+import GHC.ST (ST (..))  import Data.Text.Builder.Linear.Char import Data.Text.Builder.Linear.Core@@ -46,13 +46,14 @@ -- >>> :set -XOverloadedStrings -XLinearTypes -- >>> runBuffer (\b -> b |> "foo" |> "bar") -- "foobar"--- (|>) ∷ Buffer ⊸ Text → Buffer+ infixl 6 |>-buffer |> (Text src srcOff srcLen) = appendExact-  srcLen-  (\dst dstOff → A.copyI srcLen dst dstOff src srcOff)-  buffer+buffer |> (Text src srcOff srcLen) =+  appendExact+    srcLen+    (\dst dstOff → A.copyI srcLen dst dstOff src srcOff)+    buffer  -- | Prepend 'Text' prefix to a 'Buffer' by mutating it. -- If a prefix is statically known, consider using '(<|#)' for optimal performance.@@ -60,13 +61,14 @@ -- >>> :set -XOverloadedStrings -XLinearTypes -- >>> runBuffer (\b -> "foo" <| "bar" <| b) -- "foobar"--- (<|) ∷ Text → Buffer ⊸ Buffer+ infixr 6 <|-Text src srcOff srcLen <| buffer = prependExact-  srcLen-  (\dst dstOff → A.copyI srcLen dst dstOff src srcOff)-  buffer+Text src srcOff srcLen <| buffer =+  prependExact+    srcLen+    (\dst dstOff → A.copyI srcLen dst dstOff src srcOff)+    buffer  -- | Append a null-terminated UTF-8 string -- to a 'Buffer' by mutating it. E. g.,@@ -75,16 +77,18 @@ -- >>> runBuffer (\b -> b |># "foo"# |># "bar"#) -- "foobar" ----- The literal string must not contain zero bytes @\\0@, this condition is not checked.+-- The literal string must not contain zero bytes @\\0@ and must be a valid UTF-8,+-- these conditions are not checked. -- -- Note the inconsistency in naming: unfortunately, GHC parser does not allow for @#<|@.--- (|>#) ∷ Buffer ⊸ Addr# → Buffer+ infixl 6 |>#-buffer |># addr# = appendExact-  srcLen-  (\dst dstOff → A.copyFromPointer dst dstOff (Ptr addr#) srcLen)-  buffer+buffer |># addr# =+  appendExact+    srcLen+    (\dst dstOff → A.copyFromPointer dst dstOff (Ptr addr#) srcLen)+    buffer   where     srcLen = I# (cstringLength# addr#) @@ -95,40 +99,56 @@ -- >>> runBuffer (\b -> "foo"# <|# "bar"# <|# b) -- "foobar" ----- The literal string must not contain zero bytes @\\0@, this condition is not checked.+-- The literal string must not contain zero bytes @\\0@ and must be a valid UTF-8,+-- these conditions are not checked. (<|#) ∷ Addr# → Buffer ⊸ Buffer+ infixr 6 <|#-addr# <|# buffer = prependExact-  srcLen-  (\dst dstOff → A.copyFromPointer dst dstOff (Ptr addr#) srcLen)-  buffer+addr# <|# buffer =+  prependExact+    srcLen+    (\dst dstOff → A.copyFromPointer dst dstOff (Ptr addr#) srcLen)+    buffer   where     srcLen = I# (cstringLength# addr#)  -- | Append given number of spaces. (|>…) ∷ Buffer ⊸ Word → Buffer+ infixr 6 |>… buf |>… 0 = buf-buffer |>… (fromIntegral -> spaces@(I# spaces#)) = appendExact-  spaces-  (\(A.MutableByteArray dst#) (I# dstOff#) -> ST (\s# ->-    (# setByteArray# dst# dstOff# spaces# 32# s#, () #)))-  buffer+buffer |>… (fromIntegral → spaces@(I# spaces#)) =+  appendExact+    spaces+    ( \(A.MutableByteArray dst#) (I# dstOff#) →+        ST+          ( \s# →+              (# setByteArray# dst# dstOff# spaces# 32# s#, () #)+          )+    )+    buffer  -- | Prepend given number of spaces. (…<|) ∷ Word → Buffer ⊸ Buffer+ infixr 6 …<| 0 …<| buf = buf-(fromIntegral -> spaces@(I# spaces#)) …<| buffer = prependExact-  spaces-  (\(A.MutableByteArray dst#) (I# dstOff#) -> ST (\s# ->-    (# setByteArray# dst# dstOff# spaces# 32# s#, () #)))-  buffer+(fromIntegral → spaces@(I# spaces#)) …<| buffer =+  prependExact+    spaces+    ( \(A.MutableByteArray dst#) (I# dstOff#) →+        ST+          ( \s# →+              (# setByteArray# dst# dstOff# spaces# 32# s#, () #)+          )+    )+    buffer  -- | This is just a normal 'Data.List.foldl'', but with a linear arrow--- and potentially unlifted accumulator.-foldlIntoBuffer ∷ (Buffer ⊸ a → Buffer) → Buffer ⊸ [a] → Buffer+-- and unlifted accumulator.+foldlIntoBuffer ∷ ∀ a. (Buffer ⊸ a → Buffer) → Buffer ⊸ [a] → Buffer foldlIntoBuffer f = go   where+    go ∷ Buffer ⊸ [a] → Buffer     go !acc [] = acc     go !acc (x : xs) = go (f acc x) xs
src/Data/Text/Builder/Linear/Char.hs view
@@ -2,16 +2,15 @@ -- Copyright:   (c) 2022 Andrew Lelechenko -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--module Data.Text.Builder.Linear.Char-  ( -- * Buffer-    (|>.)-  , (.<|)-  ) where+module Data.Text.Builder.Linear.Char (+  -- * Buffer+  (|>.),+  (.<|),+) where -import qualified Data.Text.Array as A-import Data.Text.Internal.Encoding.Utf8 (utf8Length, ord2, ord3, ord4)-import Data.Text.Internal.Unsafe.Char (unsafeWrite, ord)+import Data.Text.Array qualified as A+import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4, utf8Length)+import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite) import GHC.ST (ST)  import Data.Text.Builder.Linear.Core@@ -22,7 +21,10 @@ -- >>> runBuffer (\b -> b |>. 'q' |>. 'w') -- "qw" --+-- In contrast to 'Data.Text.Lazy.Builder.singleton', it's a responsibility+-- of the caller to sanitize surrogate code points with 'Data.Text.Internal.safe'. (|>.) ∷ Buffer ⊸ Char → Buffer+ infixl 6 |>. buffer |>. ch = appendBounded 4 (\dst dstOff → unsafeWrite dst dstOff ch) buffer @@ -32,17 +34,21 @@ -- >>> runBuffer (\b -> 'q' .<| 'w' .<| b) -- "qw" --+-- In contrast to 'Data.Text.Lazy.Builder.singleton', it's a responsibility+-- of the caller to sanitize surrogate code points with 'Data.Text.Internal.safe'. (.<|) ∷ Char → Buffer ⊸ Buffer+ infixr 6 .<|-ch .<| buffer = prependBounded-  4-  (\dst dstOff → unsafePrependCharM dst dstOff ch)-  (\dst dstOff → unsafeWrite dst dstOff ch)-  buffer+ch .<| buffer =+  prependBounded+    4+    (\dst dstOff → unsafePrependCharM dst dstOff ch)+    (\dst dstOff → unsafeWrite dst dstOff ch)+    buffer  -- | Similar to 'Data.Text.Internal.Unsafe.Char.unsafeWrite', -- but writes _before_ a given offset.-unsafePrependCharM :: A.MArray s → Int → Char → ST s Int+unsafePrependCharM ∷ A.MArray s → Int → Char → ST s Int unsafePrependCharM marr off c = case utf8Length c of   1 → do     let n0 = fromIntegral (ord c)
src/Data/Text/Builder/Linear/Core.hs view
@@ -4,33 +4,32 @@ -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com> -- -- Low-level routines for 'Buffer' manipulations.--module Data.Text.Builder.Linear.Core-  ( Buffer-  , runBuffer-  , dupBuffer-  , consumeBuffer-  , eraseBuffer-  , byteSizeOfBuffer-  , lengthOfBuffer-  , dropBuffer-  , takeBuffer-  , appendBounded-  , appendExact-  , prependBounded-  , prependExact-  , (><)-  ) where+module Data.Text.Builder.Linear.Core (+  Buffer,+  runBuffer,+  runBufferBS,+  dupBuffer,+  consumeBuffer,+  eraseBuffer,+  byteSizeOfBuffer,+  lengthOfBuffer,+  dropBuffer,+  takeBuffer,+  appendBounded,+  appendExact,+  prependBounded,+  prependExact,+  (><),+) where -import qualified Data.Text as T-import Data.Text.Array (Array(..), MArray(..))-import qualified Data.Text.Array as A-import Data.Text.Internal (Text(..))-import GHC.Exts (unsafeCoerce#, Int(..), sizeofByteArray#)-#if MIN_VERSION_base(4,16,0)-import GHC.Exts (TYPE, Levity(..), RuntimeRep(..))-#endif-import GHC.ST (ST(..), runST)+import Data.ByteString.Internal (ByteString (..))+import Data.Text qualified as T+import Data.Text.Array (Array (..), MArray (..))+import Data.Text.Array qualified as A+import Data.Text.Internal (Text (..))+import GHC.Exts (Int (..), Levity (..), RuntimeRep (..), TYPE, byteArrayContents#, isByteArrayPinned#, isTrue#, plusAddr#, sizeofByteArray#, unsafeCoerce#)+import GHC.ForeignPtr (ForeignPtr (..), ForeignPtrContents (..))+import GHC.ST (ST (..), runST)  -- | Internally 'Buffer' is a mutable buffer. -- If a client gets hold of a variable of type 'Buffer',@@ -39,8 +38,12 @@ -- clients always work with linear functions 'Buffer' ⊸ 'Buffer' instead -- and run them on an empty 'Buffer' to extract results. ----- In terms of @linear-base@ 'Buffer' is @Consumable@ (see 'consumeBuffer')--- and @Dupable@ (see 'dupBuffer'), but not @Movable@.+-- In terms of [@linear-base@](https://hackage.haskell.org/package/linear-base)+-- 'Buffer' is [@Consumable@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#t:Consumable)+-- (see 'consumeBuffer')+-- and [@Dupable@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#t:Dupable)+-- (see 'dupBuffer'),+-- but not [@Movable@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#t:Movable). -- -- >>> :set -XOverloadedStrings -XLinearTypes -- >>> import Data.Text.Builder.Linear.Buffer@@ -50,15 +53,10 @@ -- Remember: this is a strict builder, so on contrary to "Data.Text.Lazy.Builder" -- for optimal performance you should use strict left folds instead of lazy right ones. ----- Starting from GHC 9.2, 'Buffer' is an unlifted datatype,+-- 'Buffer' is an unlifted datatype, -- so you can put it into an unboxed tuple @(# ..., ... #)@, -- but not into @(..., ...)@.----#if MIN_VERSION_base(4,16,0) data Buffer ∷ TYPE ('BoxedRep 'Unlifted) where-#else-data Buffer where-#endif   Buffer ∷ {-# UNPACK #-} !Text → Buffer  -- | Unwrap 'Buffer', no-op.@@ -67,24 +65,51 @@ unBuffer ∷ Buffer ⊸ Text unBuffer (Buffer x) = x --- | Run a linear function on an empty 'Buffer', producing 'Text'.+-- | Run a linear function on an empty 'Buffer', producing a strict 'Text'. -- -- Be careful to write @runBuffer (\b -> ...)@ instead of @runBuffer $ \b -> ...@, -- because current implementation of linear types lacks special support for '($)'. -- Another option is to enable @{-# LANGUAGE BlockArguments #-}@ -- and write @runBuffer \b -> ...@.--- Alternatively, you can import @Prelude.Linear.($)@ from @linear-base@.------ 'runBuffer' is similar in spirit to mutable arrays API in @Data.Array.Mutable.Linear@,--- which provides functions like @fromList@ ∷ [@a@] → (@Vector@ @a@ ⊸ @Ur@ b) ⊸ @Ur@ @b@.--- Here the initial buffer is always empty and @b@ is 'Text'. Since 'Text' is @Movable@,--- 'Text' and @Ur@ 'Text' are equivalent.+-- Alternatively, you can import+-- [@($)@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#v:-36-)+-- from [@linear-base@](https://hackage.haskell.org/package/linear-base). --+-- 'runBuffer' is similar in spirit to mutable arrays API in+-- [@Data.Array.Mutable.Linear@](https://hackage.haskell.org/package/linear-base/docs/Data-Array-Mutable-Linear.html),+-- which provides functions like+-- [@fromList@](https://hackage.haskell.org/package/linear-base/docs/Data-Array-Mutable-Linear.html#v:fromList) ∷ [@a@] → (@Vector@ @a@ ⊸ [@Ur@](https://hackage.haskell.org/package/linear-base-0.3.0/docs/Prelude-Linear.html#t:Ur) b) ⊸ [@Ur@](https://hackage.haskell.org/package/linear-base-0.3.0/docs/Prelude-Linear.html#t:Ur) @b@.+-- Here the initial buffer is always empty and @b@ is 'Text'. Since 'Text' is+-- [@Movable@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#t:Movable),+-- 'Text' and [@Ur@](https://hackage.haskell.org/package/linear-base-0.3.0/docs/Prelude-Linear.html#t:Ur) 'Text' are equivalent. runBuffer ∷ (Buffer ⊸ Buffer) ⊸ Text-runBuffer f = unBuffer (f (Buffer mempty))+runBuffer f = unBuffer (shrinkBuffer (f (Buffer mempty))) +-- | Same as 'runBuffer', but returning a UTF-8 encoded strict 'ByteString'.+runBufferBS ∷ (Buffer ⊸ Buffer) ⊸ ByteString+runBufferBS f = case shrinkBuffer (f (Buffer memptyPinned)) of+  Buffer (Text (ByteArray arr) (I# from) len) → BS fp len+    where+      addr# = byteArrayContents# arr `plusAddr#` from+      fp = ForeignPtr addr# (PlainPtr (unsafeCoerce# arr))++shrinkBuffer ∷ Buffer ⊸ Buffer+shrinkBuffer (Buffer (Text arr from len)) = Buffer $ runST $ do+  arrM ← unsafeThaw arr+  A.shrinkM arrM (from + len)+  arr' ← A.unsafeFreeze arrM+  pure $ Text arr' from len++memptyPinned ∷ Text+memptyPinned = runST $ do+  marr ← A.newPinned 0+  arr ← A.unsafeFreeze marr+  pure $ Text arr 0 0+ -- | Duplicate builder. Feel free to process results in parallel threads.--- Similar to @Data.Unrestricted.Linear.Dupable@ from @linear-base@.+-- Similar to+-- [@Dupable@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#t:Dupable)+-- from [@linear-base@](https://hackage.haskell.org/package/linear-base). -- -- It is a bit tricky to use because of -- <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/linear_types.html#limitations current limitations>@@ -99,20 +124,22 @@ -- >>> runBuffer (\b -> (\(# b1, b2 #) -> ("foo" <| b1) >< (b2 |> "bar")) (dupBuffer b)) -- "foobar" ----- Note the unboxed tuple: starting from GHC 9.2, 'Buffer' is an unlifted datatype,+-- Note the unboxed tuple: 'Buffer' is an unlifted datatype, -- so it cannot be put into @(..., ...)@.--- dupBuffer ∷ Buffer ⊸ (# Buffer, Buffer #) dupBuffer (Buffer x) = (# Buffer x, Buffer (T.copy x) #)  -- | Consume buffer linearly,--- similar to @Data.Unrestricted.Linear.Consumable@ from @linear-base@.+-- similar to+-- [@Consumable@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#t:Consumable)+-- from [@linear-base@](https://hackage.haskell.org/package/linear-base). consumeBuffer ∷ Buffer ⊸ ()-consumeBuffer Buffer{} = ()+consumeBuffer Buffer {} = ()  -- | Erase buffer's content, replacing it with an empty 'Text'. eraseBuffer ∷ Buffer ⊸ Buffer-eraseBuffer Buffer{} = Buffer mempty+eraseBuffer (Buffer (Text arr _ _)) =+  Buffer (if isPinned arr then memptyPinned else mempty)  -- | Return buffer's size in __bytes__ (not in 'Char's). -- This could be useful to implement a lazy builder atop of a strict one.@@ -153,7 +180,7 @@ appendBounded   ∷ Int   -- ^ Upper bound for the number of bytes, written by an action-  → (forall s. MArray s → Int → ST s Int)+  → (∀ s. MArray s → Int → ST s Int)   -- ^ Action, which writes bytes __starting__ from the given offset   -- and returns an actual number of bytes written.   → Buffer@@ -161,12 +188,13 @@ appendBounded maxSrcLen appender (Buffer (Text dst dstOff dstLen)) = Buffer $ runST $ do   let dstFullLen = sizeofByteArray dst       newFullLen = dstOff + 2 * (dstLen + maxSrcLen)-  newM ← if dstOff + dstLen + maxSrcLen <= dstFullLen-    then unsafeThaw dst-    else do-      tmpM ← A.new newFullLen-      A.copyI dstLen tmpM dstOff dst dstOff-      pure tmpM+  newM ←+    if dstOff + dstLen + maxSrcLen <= dstFullLen+      then unsafeThaw dst+      else do+        tmpM ← (if isPinned dst then A.newPinned else A.new) newFullLen+        A.copyI dstLen tmpM dstOff dst dstOff+        pure tmpM   srcLen ← appender newM (dstOff + dstLen)   new ← A.unsafeFreeze newM   pure $ Text new dstOff (dstLen + srcLen)@@ -176,56 +204,58 @@ appendExact   ∷ Int   -- ^ Exact number of bytes, written by an action-  → (forall s. MArray s → Int → ST s ())+  → (∀ s. MArray s → Int → ST s ())   -- ^ Action, which writes bytes __starting__ from the given offset   → Buffer   ⊸ Buffer-appendExact srcLen appender = appendBounded-  srcLen-  (\dst dstOff → appender dst dstOff >> pure srcLen)+appendExact srcLen appender =+  appendBounded+    srcLen+    (\dst dstOff → appender dst dstOff >> pure srcLen) {-# INLINE appendExact #-}  -- | Low-level routine to prepend data of unknown size to a 'Buffer'. prependBounded   ∷ Int   -- ^ Upper bound for the number of bytes, written by an action-  → (forall s. MArray s → Int → ST s Int)+  → (∀ s. MArray s → Int → ST s Int)   -- ^ Action, which writes bytes __finishing__ before the given offset   -- and returns an actual number of bytes written.-  → (forall s. MArray s → Int → ST s Int)+  → (∀ s. MArray s → Int → ST s Int)   -- ^ Action, which writes bytes __starting__ from the given offset   -- and returns an actual number of bytes written.   → Buffer   ⊸ Buffer prependBounded maxSrcLen prepender appender (Buffer (Text dst dstOff dstLen))   | maxSrcLen <= dstOff = Buffer $ runST $ do-    newM ← unsafeThaw dst-    srcLen ← prepender newM dstOff-    new ← A.unsafeFreeze newM-    pure $ Text new (dstOff - srcLen) (srcLen + dstLen)+      newM ← unsafeThaw dst+      srcLen ← prepender newM dstOff+      new ← A.unsafeFreeze newM+      pure $ Text new (dstOff - srcLen) (srcLen + dstLen)   | otherwise = Buffer $ runST $ do-    let dstFullLen = sizeofByteArray dst-        newOff = dstLen + maxSrcLen-        newFullLen = 2 * newOff + (dstFullLen - dstOff - dstLen)-    newM ← A.new newFullLen-    srcLen ← appender newM newOff-    A.copyI dstLen newM (newOff + srcLen) dst dstOff-    new ← A.unsafeFreeze newM-    pure $ Text new newOff (dstLen + srcLen)+      let dstFullLen = sizeofByteArray dst+          newOff = dstLen + maxSrcLen+          newFullLen = 2 * newOff + (dstFullLen - dstOff - dstLen)+      newM ← (if isPinned dst then A.newPinned else A.new) newFullLen+      srcLen ← appender newM newOff+      A.copyI dstLen newM (newOff + srcLen) dst dstOff+      new ← A.unsafeFreeze newM+      pure $ Text new newOff (dstLen + srcLen) {-# INLINE prependBounded #-}  -- | Low-level routine to append data of unknown size to a 'Buffer'. prependExact   ∷ Int   -- ^ Exact number of bytes, written by an action-  → (forall s. MArray s → Int → ST s ())+  → (∀ s. MArray s → Int → ST s ())   -- ^ Action, which writes bytes __starting__ from the given offset   → Buffer   ⊸ Buffer-prependExact srcLen appender = prependBounded-  srcLen-  (\dst dstOff → appender dst (dstOff - srcLen) >> pure srcLen)-  (\dst dstOff → appender dst dstOff >> pure srcLen)+prependExact srcLen appender =+  prependBounded+    srcLen+    (\dst dstOff → appender dst (dstOff - srcLen) >> pure srcLen)+    (\dst dstOff → appender dst dstOff >> pure srcLen) {-# INLINE prependExact #-}  unsafeThaw ∷ Array → ST s (MArray s)@@ -235,6 +265,9 @@ sizeofByteArray ∷ Array → Int sizeofByteArray (ByteArray a) = I# (sizeofByteArray# a) +isPinned ∷ Array → Bool+isPinned (ByteArray a) = isTrue# (isByteArrayPinned# a)+ -- | Concatenate two 'Buffer's, potentially mutating both of them. -- -- You likely need to use 'dupBuffer' to get hold on two builders at once:@@ -243,8 +276,8 @@ -- >>> import Data.Text.Builder.Linear.Buffer -- >>> runBuffer (\b -> (\(# b1, b2 #) -> ("foo" <| b1) >< (b2 |> "bar")) (dupBuffer b)) -- "foobar"--- (><) ∷ Buffer ⊸ Buffer ⊸ Buffer+ infix 6 >< Buffer (Text left leftOff leftLen) >< Buffer (Text right rightOff rightLen) = Buffer $ runST $ do   let leftFullLen = sizeofByteArray left@@ -252,20 +285,23 @@       canCopyToLeft = leftOff + leftLen + rightLen <= leftFullLen       canCopyToRight = leftLen <= rightOff       shouldCopyToLeft = canCopyToLeft && (not canCopyToRight || leftLen >= rightLen)-  if shouldCopyToLeft then do-    newM ← unsafeThaw left-    A.copyI rightLen newM (leftOff + leftLen) right rightOff-    new ← A.unsafeFreeze newM-    pure $ Text new leftOff (leftLen + rightLen)-  else if canCopyToRight then do-    newM ← unsafeThaw right-    A.copyI leftLen newM (rightOff - leftLen) left leftOff-    new ← A.unsafeFreeze newM-    pure $ Text new (rightOff - leftLen) (leftLen + rightLen)-  else do-    let fullLen = leftOff + leftLen + rightLen + (rightFullLen - rightOff - rightLen)-    newM ← A.new fullLen-    A.copyI leftLen newM leftOff left leftOff-    A.copyI rightLen newM (leftOff + leftLen) right rightOff-    new ← A.unsafeFreeze newM-    pure $ Text new leftOff (leftLen + rightLen)+  if shouldCopyToLeft+    then do+      newM ← unsafeThaw left+      A.copyI rightLen newM (leftOff + leftLen) right rightOff+      new ← A.unsafeFreeze newM+      pure $ Text new leftOff (leftLen + rightLen)+    else+      if canCopyToRight+        then do+          newM ← unsafeThaw right+          A.copyI leftLen newM (rightOff - leftLen) left leftOff+          new ← A.unsafeFreeze newM+          pure $ Text new (rightOff - leftLen) (leftLen + rightLen)+        else do+          let fullLen = leftOff + leftLen + rightLen + (rightFullLen - rightOff - rightLen)+          newM ← (if isPinned left || isPinned right then A.newPinned else A.new) fullLen+          A.copyI leftLen newM leftOff left leftOff+          A.copyI rightLen newM (leftOff + leftLen) right rightOff+          new ← A.unsafeFreeze newM+          pure $ Text new leftOff (leftLen + rightLen)
src/Data/Text/Builder/Linear/Dec.hs view
@@ -1,20 +1,26 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+ -- | -- Copyright:   (c) 2022 Andrew Lelechenko -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+#ifdef aarch64_HOST_ARCH+{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-top-binds #-}+#endif -{-# LANGUAGE TemplateHaskell #-}+module Data.Text.Builder.Linear.Dec (+  (|>$),+  ($<|),+) where -module Data.Text.Builder.Linear.Dec-  ( (|>$)-  , ($<|)-  ) where+#include "MachDeps.h" -import Data.Bits (FiniteBits(..), Bits(..))-import Data.Int (Int8, Int16, Int32, Int64)-import qualified Data.Text.Array as A-import Data.Word (Word8, Word16, Word32, Word64)-import GHC.Exts (Addr#, Int(..), Ptr(..), (>=#), dataToTag#)+import Data.Bits (Bits (..), FiniteBits (..))+import Data.Int (Int16, Int32, Int8)+import Data.Text.Array qualified as A+import Data.Word (Word16, Word32, Word8)+import GHC.Exts (Addr#, Int (..), Ptr (..), dataToTag#, (>=#)) import GHC.Ptr (plusPtr) import GHC.ST (ST) import Numeric.QuoteQuot (assumeNonNegArg, astQuot, quoteAST, quoteQuot)@@ -22,113 +28,140 @@ import Data.Text.Builder.Linear.Core  -- | Append decimal number.-(|>$) :: (Integral a, FiniteBits a) => Buffer ⊸ a → Buffer+(|>$) ∷ (Integral a, FiniteBits a) ⇒ Buffer ⊸ a → Buffer+ infixl 6 |>$-buffer |>$ n = appendBounded-  (maxDecLen n)-  (\dst dstOff → unsafeAppendDec dst dstOff n)-  buffer-{-# INLINABLE (|>$) #-}+buffer |>$ n =+  appendBounded+    (maxDecLen n)+    (\dst dstOff → unsafeAppendDec dst dstOff n)+    buffer+{-# INLINEABLE (|>$) #-}  -- | Prepend decimal number.-($<|) :: (Integral a, FiniteBits a) => a → Buffer ⊸ Buffer+($<|) ∷ (Integral a, FiniteBits a) ⇒ a → Buffer ⊸ Buffer+ infixr 6 $<|-n $<| buffer = prependBounded-  (maxDecLen n)-  (\dst dstOff → unsafePrependDec dst dstOff n)-  (\dst dstOff → unsafeAppendDec dst dstOff n)-  buffer-{-# INLINABLE ($<|) #-}+n $<| buffer =+  prependBounded+    (maxDecLen n)+    (\dst dstOff → unsafePrependDec dst dstOff n)+    (\dst dstOff → unsafeAppendDec dst dstOff n)+    buffer+{-# INLINEABLE ($<|) #-}  -- | ceiling (fbs a * logBase 10 2) < ceiling (fbs a * 5 / 16) < 1 + floor (fbs a * 5 / 16)-maxDecLen :: FiniteBits a => a → Int+maxDecLen ∷ FiniteBits a ⇒ a → Int maxDecLen a   | isSigned a = 2 + (finiteBitSize a * 5) `shiftR` 4-  | otherwise  = 1 + (finiteBitSize a * 5) `shiftR` 4-{-# INLINABLE maxDecLen #-}+  | otherwise = 1 + (finiteBitSize a * 5) `shiftR` 4+{-# INLINEABLE maxDecLen #-} -exactDecLen :: (Integral a, FiniteBits a) => a → Int+exactDecLen ∷ (Integral a, FiniteBits a) ⇒ a → Int exactDecLen n-  | n < 0-  = go 2 (complement n + fromIntegral (I# (dataToTag# (n > bit (finiteBitSize n - 1)))))-  | otherwise-  = go 1 n+  | n < 0 =+      go 2 (complement n + fromIntegral (I# (dataToTag# (n > bit (finiteBitSize n - 1)))))+  | otherwise =+      go 1 n   where-    go :: (Integral a, FiniteBits a) => Int → a → Int+    go ∷ (Integral a, FiniteBits a) ⇒ Int → a → Int     go acc k-      | finiteBitSize k >= 32, k >= 1000000000 = go (acc + 9) (quotBillion k)+      | finiteBitSize k >= 30, k >= 1000000000 = go (acc + 9) (quotBillion k)       | otherwise = acc + goInt (fromIntegral k)      goInt l@(I# l#)-      | l >= 1e5  = 5 + I# (l# >=# 100000000#) + I# (l# >=# 10000000#) + I# (l# >=# 1000000#)+      | l >= 1e5 = 5 + I# (l# >=# 100000000#) + I# (l# >=# 10000000#) + I# (l# >=# 1000000#)       | otherwise = I# (l# >=# 10000#) + I# (l# >=# 1000#) + I# (l# >=# 100#) + I# (l# >=# 10#)-{-# INLINABLE exactDecLen #-}+{-# INLINEABLE exactDecLen #-} -unsafeAppendDec :: (Integral a, FiniteBits a) => A.MArray s → Int → a → ST s Int+unsafeAppendDec ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int unsafeAppendDec marr off n = unsafePrependDec marr (off + exactDecLen n) n-{-# INLINABLE unsafeAppendDec #-}+{-# INLINEABLE unsafeAppendDec #-} -unsafePrependDec :: (Integral a, FiniteBits a) => A.MArray s → Int → a → ST s Int-unsafePrependDec marr off n-  | n < 0, n == bit (finiteBitSize n - 1) = do-    A.unsafeWrite marr (off - 1) (fromIntegral (48 + minBoundLastDigit n))-    go (off - 2) (abs (bit (finiteBitSize n - 1) `quot` 10)) >>= sign+unsafePrependDec ∷ ∀ s a. (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int+unsafePrependDec marr !off n+  | n < 0+  , n == bit (finiteBitSize n - 1) = do+      A.unsafeWrite marr (off - 1) (fromIntegral (48 + minBoundLastDigit n))+      go (off - 2) (abs (bit (finiteBitSize n - 1) `quot` 10)) >>= sign   | n == 0 = do-    A.unsafeWrite marr (off - 1) 0x30 >> pure 1+      A.unsafeWrite marr (off - 1) 0x30 >> pure 1   | otherwise = go (off - 1) (abs n) >>= sign   where-    sign o+    sign !o       | n > 0 = pure (off - o)       | otherwise = do-        A.unsafeWrite marr (o - 1) 0x2d -- '-'-        pure (off - o + 1)+          A.unsafeWrite marr (o - 1) 0x2d -- '-'+          pure (off - o + 1) +    go ∷ Int → a → ST s Int     go o k       | k >= 10 = do-        let q = quot100 k-            r = k - 100 * q-        A.copyFromPointer marr (o - 1) (Ptr digits `plusPtr` (fromIntegral r `shiftL` 1)) 2-        if k < 100 then pure (o - 1) else go (o - 2) q+          let (q, r) = quotRem100 k+          A.copyFromPointer marr (o - 1) (Ptr digits `plusPtr` (fromIntegral r `shiftL` 1)) 2+          if k < 100 then pure (o - 1) else go (o - 2) q       | otherwise = do-        A.unsafeWrite marr o (fromIntegral (48 + k))-        pure o+          A.unsafeWrite marr o (fromIntegral (48 + k))+          pure o -    digits :: Addr#+    digits ∷ Addr#     digits = "00010203040506070809101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899"#-{-# INLINABLE unsafePrependDec #-}+{-# INLINEABLE unsafePrependDec #-} -minBoundLastDigit :: FiniteBits a => a → Int+minBoundLastDigit ∷ FiniteBits a ⇒ a → Int minBoundLastDigit a = case finiteBitSize a .&. 4 of   0 → 8   1 → 6   2 → 2   _ → 4-{-# INLINABLE minBoundLastDigit #-}+{-# INLINEABLE minBoundLastDigit #-} -quot100 :: (Integral a, FiniteBits a) => a → a+quotRem100 ∷ (Integral a, FiniteBits a) ⇒ a → (a, a)++-- https://gitlab.haskell.org/ghc/ghc/-/issues/22933+#ifdef aarch64_HOST_ARCH+quotRem100 a = a `quotRem` 100+#else+quotRem100 a = let q = quot100 a in (q, a - 100 * q)+#endif+{-# INLINEABLE quotRem100 #-}++quot100 ∷ (Integral a, FiniteBits a) ⇒ a → a quot100 a = case (finiteBitSize a, isSigned a) of-  (64, True)  → cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 :: Int64))-  (64, False) → cast $$(quoteQuot (100 :: Word64))-  (32, True)  → cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 :: Int32))-  (32, False) → cast $$(quoteQuot (100 :: Word32))-  (16, True)  → cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 :: Int16))-  (16, False) → cast $$(quoteQuot (100 :: Word16))-  ( 8, True)  → cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 :: Int8))-  ( 8, False) → cast $$(quoteQuot (100 :: Word8))+  (64, True)+    | finiteBitSize (0 ∷ Int) == 64 →+        cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 ∷ Int))+  (64, False)+    | finiteBitSize (0 ∷ Word) == 64 →+        cast $$(quoteQuot (100 ∷ Word))+  (32, True) → cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 ∷ Int32))+  (32, False) → cast $$(quoteQuot (100 ∷ Word32))+  (16, True) → cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 ∷ Int16))+  (16, False) → cast $$(quoteQuot (100 ∷ Word16))+  (8, True) → cast $$(quoteAST $ assumeNonNegArg $ astQuot (100 ∷ Int8))+  (8, False) → cast $$(quoteQuot (100 ∷ Word8))   _ → a `quot` 100   where-    cast :: (Integral a, Integral b) => (b → b) → a+    cast ∷ (Integral a, Integral b) ⇒ (b → b) → a     cast f = fromIntegral (f (fromIntegral a))-{-# INLINABLE quot100 #-}+{-# INLINEABLE quot100 #-} -quotBillion :: (Integral a, FiniteBits a) => a → a+quotBillion ∷ (Integral a, FiniteBits a) ⇒ a → a+#ifdef aarch64_HOST_ARCH+quotBillion a = a `quot` 1e9+#else quotBillion a = case (finiteBitSize a, isSigned a) of-  (64, True)  → cast $$(quoteAST $ assumeNonNegArg $ astQuot (1e9 :: Int64))-  (64, False) → cast $$(quoteQuot (1e9 :: Word64))+  (64, True)+    | finiteBitSize (0 :: Int) == 64+    → cast $$(quoteAST $ assumeNonNegArg $ astQuot (1e9 :: Int))+  (64, False)+    | finiteBitSize (0 :: Word) == 64+    → cast $$(quoteQuot (1e9 :: Word))   (32, True)  → cast $$(quoteAST $ assumeNonNegArg $ astQuot (1e9 :: Int32))   (32, False) → cast $$(quoteQuot (1e9 :: Word32))   _ → a `quot` 1e9   where     cast :: (Integral a, Integral b) => (b → b) → a     cast f = fromIntegral (f (fromIntegral a))-{-# INLINABLE quotBillion #-}+#endif+{-# INLINEABLE quotBillion #-}
src/Data/Text/Builder/Linear/Double.hs view
@@ -2,61 +2,64 @@ -- Copyright:   (c) 2022 Andrew Lelechenko -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--module Data.Text.Builder.Linear.Double-  ( (|>%)-  , (%<|)-  ) where+module Data.Text.Builder.Linear.Double (+  (|>%),+  (%<|),+) where -import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Builder.Internal as BBI-import qualified Data.Text.Array as A+import Data.ByteString.Builder qualified as BB+import Data.ByteString.Builder.Internal qualified as BBI+import Data.Text.Array qualified as A import Data.Word (Word8)-import GHC.Exts (Ptr(..))-import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr, unsafeWithForeignPtr, ForeignPtr)-import GHC.IO (unsafeIOToST, unsafeSTToIO, unsafeDupablePerformIO)+import GHC.Exts (Ptr (..))+import GHC.ForeignPtr (ForeignPtr, touchForeignPtr, unsafeForeignPtrToPtr, unsafeWithForeignPtr)+import GHC.IO (unsafeDupablePerformIO, unsafeIOToST, unsafeSTToIO) import GHC.Ptr (minusPtr) import GHC.ST (ST)  import Data.Text.Builder.Linear.Core  -- | Append double.-(|>%) :: Buffer ⊸ Double → Buffer+(|>%) ∷ Buffer ⊸ Double → Buffer+ infixl 6 |>%-buffer |>% x = appendBounded-  maxDblLen-  (\dst dstOff → unsafeAppendDouble dst dstOff x)-  buffer+buffer |>% x =+  appendBounded+    maxDblLen+    (\dst dstOff → unsafeAppendDouble dst dstOff x)+    buffer  -- | Prepend double-(%<|) :: Double → Buffer ⊸ Buffer+(%<|) ∷ Double → Buffer ⊸ Buffer+ infixr 6 %<|-x %<| buffer = prependBounded-  maxDblLen-  (\dst dstOff → unsafePrependDouble dst dstOff x)-  (\dst dstOff → unsafeAppendDouble dst dstOff x)-  buffer+x %<| buffer =+  prependBounded+    maxDblLen+    (\dst dstOff → unsafePrependDouble dst dstOff x)+    (\dst dstOff → unsafeAppendDouble dst dstOff x)+    buffer -unsafeAppendDouble :: A.MArray s → Int → Double → ST s Int+unsafeAppendDouble ∷ A.MArray s → Int → Double → ST s Int unsafeAppendDouble dst !dstOff !x = do   let (fp, !srcLen) = runDoubleBuilder x   unsafeIOToST $ unsafeWithForeignPtr fp $ \(Ptr addr#) →     unsafeSTToIO $ A.copyFromPointer dst dstOff (Ptr addr#) srcLen   pure srcLen -unsafePrependDouble :: A.MArray s → Int → Double → ST s Int+unsafePrependDouble ∷ A.MArray s → Int → Double → ST s Int unsafePrependDouble dst !dstOff !x = do   let (fp, !srcLen) = runDoubleBuilder x   unsafeIOToST $ unsafeWithForeignPtr fp $ \(Ptr addr#) →     unsafeSTToIO $ A.copyFromPointer dst (dstOff - srcLen) (Ptr addr#) srcLen   pure srcLen -runDoubleBuilder :: Double → (ForeignPtr Word8, Int)+runDoubleBuilder ∷ Double → (ForeignPtr Word8, Int) runDoubleBuilder =   unsafeDupablePerformIO . buildStepToFirstChunk . BBI.runBuilder . BB.doubleDec {-# INLINE runDoubleBuilder #-} -buildStepToFirstChunk :: BBI.BuildStep a → IO (ForeignPtr Word8, Int)+buildStepToFirstChunk ∷ BBI.BuildStep a → IO (ForeignPtr Word8, Int) buildStepToFirstChunk = \step → BBI.newBuffer maxDblLen >>= fill step   where     fill !step (BBI.Buffer fpbuf br) = do@@ -66,5 +69,5 @@       touchForeignPtr fpbuf       return res -maxDblLen :: Int+maxDblLen ∷ Int maxDblLen = 24 -- length (show (-1.0000000000000004e-308 :: Double))
src/Data/Text/Builder/Linear/Hex.hs view
@@ -2,66 +2,73 @@ -- Copyright:   (c) 2022 Andrew Lelechenko -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>--module Data.Text.Builder.Linear.Hex-  ( (|>&)-  , (&<|)-  ) where+module Data.Text.Builder.Linear.Hex (+  (|>&),+  (&<|),+) where -import Data.Bits (FiniteBits(..), Bits(..))-import Data.Foldable (forM_)-import qualified Data.Text.Array as A-import GHC.Exts (Int(..), (>#), (<=#))+import Data.Bits (Bits (..), FiniteBits (..))+import Data.Text.Array qualified as A+import GHC.Exts (Int (..), (>#)) import GHC.ST (ST)  import Data.Text.Builder.Linear.Core  -- | Append hexadecimal number.-(|>&) :: (Integral a, FiniteBits a) => Buffer ⊸ a → Buffer+(|>&) ∷ (Integral a, FiniteBits a) ⇒ Buffer ⊸ a → Buffer+ infixl 6 |>&-buffer |>& n = appendBounded-  (finiteBitSize n `shiftR` 2)-  (\dst dstOff → unsafeAppendHex dst dstOff n)-  buffer-{-# INLINABLE (|>&) #-}+buffer |>& n =+  appendBounded+    (finiteBitSize n `shiftR` 2)+    (\dst dstOff → unsafeAppendHex dst dstOff n)+    buffer+{-# INLINEABLE (|>&) #-}  -- | Prepend hexadecimal number.-(&<|) :: (Integral a, FiniteBits a) => a → Buffer ⊸ Buffer+(&<|) ∷ (Integral a, FiniteBits a) ⇒ a → Buffer ⊸ Buffer+ infixr 6 &<|-n &<| buffer = prependBounded-  (finiteBitSize n `shiftR` 2)-  (\dst dstOff → unsafePrependHex dst dstOff n)-  (\dst dstOff → unsafeAppendHex dst dstOff n)-  buffer-{-# INLINABLE (&<|) #-}+n &<| buffer =+  prependBounded+    (finiteBitSize n `shiftR` 2)+    (\dst dstOff → unsafePrependHex dst dstOff n)+    (\dst dstOff → unsafeAppendHex dst dstOff n)+    buffer+{-# INLINEABLE (&<|) #-} -unsafeAppendHex :: (Integral a, FiniteBits a) => A.MArray s → Int → a → ST s Int-unsafeAppendHex marr off n = do-  let len = lengthAsHex n-  forM_ [0 .. len - 1] $ \i →-    let nibble = (n `shiftR` ((len - 1 - i) `shiftL` 2)) .&. 0xf in-      writeNibbleAsHex marr (off + i) (fromIntegral nibble)-  pure len-{-# INLINABLE unsafeAppendHex #-}+unsafeAppendHex ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int+unsafeAppendHex marr !off 0 =+  A.unsafeWrite marr off 0x30 >> pure 1+unsafeAppendHex marr !off n = go (off + len - 1) n+  where+    len = lengthAsHex n -unsafePrependHex :: (Integral a, FiniteBits a) => A.MArray s → Int → a → ST s Int-unsafePrependHex marr off n = do-  let len = lengthAsHex n-  forM_ [0 .. len - 1] $ \i →-    let nibble = (n `shiftR` (i `shiftL` 2)) .&. 0xf in-      writeNibbleAsHex marr (off - 1 - i) (fromIntegral nibble)-  pure len-{-# INLINABLE unsafePrependHex #-}+    go !_ 0 = pure len+    go !o m = do+      let nibble = m .&. 0x0f+      writeNibbleAsHex marr o (fromIntegral nibble)+      go (o - 1) (m `shiftR` 4)+{-# INLINEABLE unsafeAppendHex #-} -lengthAsHex :: FiniteBits a => a → Int-lengthAsHex n = max1 $ (finiteBitSize n `shiftR` 2) - (countLeadingZeros n `shiftR` 2)-{-# INLINABLE lengthAsHex #-}+unsafePrependHex ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int+unsafePrependHex marr !off 0 =+  A.unsafeWrite marr (off - 1) 0x30 >> pure 1+unsafePrependHex marr !off n = go (off - 1) n+  where+    go !o 0 = pure (off - 1 - o)+    go !o m = do+      let nibble = m .&. 0x0f+      writeNibbleAsHex marr o (fromIntegral nibble)+      go (o - 1) (m `shiftR` 4)+{-# INLINEABLE unsafePrependHex #-} --- Branchless equivalent for max 1 n.-max1 :: Int → Int-max1 n@(I# n#) = n `xor` I# (n# <=# 0#)+-- | This assumes n /= 0.+lengthAsHex ∷ FiniteBits a ⇒ a → Int+lengthAsHex n = (finiteBitSize n `shiftR` 2) - (countLeadingZeros n `shiftR` 2)+{-# INLINEABLE lengthAsHex #-} -writeNibbleAsHex :: A.MArray s → Int → Int → ST s ()+writeNibbleAsHex ∷ A.MArray s → Int → Int → ST s () writeNibbleAsHex marr off n@(I# n#) = A.unsafeWrite marr off (fromIntegral hex)   where-    hex = 48 + n + I# (n# ># 9#) * 39+    hex = 0x30 + n + I# (n# ># 9#) * (0x60 - 0x39)
test/Main.hs view
@@ -5,8 +5,10 @@  module Main where +import Data.Bits (Bits(..), FiniteBits(..)) import Data.Foldable import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Text.Builder.Linear.Buffer import Data.Text.Internal (Text(..)) import Data.Text.Lazy (toStrict)@@ -15,7 +17,7 @@ import Data.Text.Lazy.Builder.RealFloat (realFloat) import GHC.Generics import Test.Tasty-import Test.Tasty.QuickCheck hiding ((><))+import Test.Tasty.QuickCheck hiding ((><), (.&.))  instance Arbitrary Text where   arbitrary = do@@ -39,6 +41,8 @@   | PrependHex Word   | AppendDec Int   | PrependDec Int+  | AppendDec30 Int30+  | PrependDec30 Int30   | AppendDouble Double   | PrependDouble Double   | AppendSpaces Word@@ -55,6 +59,8 @@     , PrependHex    <$> arbitraryBoundedIntegral     , AppendDec     <$> arbitraryBoundedIntegral     , PrependDec    <$> arbitraryBoundedIntegral+    , AppendDec30   <$> arbitraryBoundedIntegral+    , PrependDec30  <$> arbitraryBoundedIntegral     , pure $ AppendHex minBound     , pure $ AppendHex maxBound     , pure $ AppendDec minBound@@ -79,6 +85,8 @@     go b (PrependHex    x) = toStrict (toLazyText (hexadecimal x)) <> b     go b (AppendDec     x) = b <> toStrict (toLazyText (decimal x))     go b (PrependDec    x) = toStrict (toLazyText (decimal x)) <> b+    go b (AppendDec30   x) = b <> toStrict (toLazyText (decimal x))+    go b (PrependDec30  x) = toStrict (toLazyText (decimal x)) <> b     go b (AppendDouble  x) = b <> toStrict (toLazyText (realFloat x))     go b (PrependDouble x) = toStrict (toLazyText (realFloat x)) <> b     go b (AppendSpaces  n) = b <> T.replicate (fromIntegral n) (T.singleton ' ')@@ -96,6 +104,8 @@     go b (PrependHex    x) = x &<| b     go b (AppendDec     x) = b |>$ x     go b (PrependDec    x) = x $<| b+    go b (AppendDec30   x) = b |>$ x+    go b (PrependDec30  x) = x $<| b     go b (AppendDouble  x) = b |>% x     go b (PrependDouble x) = x %<| b     go b (AppendSpaces  n) = b |>… n@@ -107,6 +117,7 @@   , testProperty "two sequences of actions" prop2   , testProperty "append addr#" prop3   , testProperty "prepend addr#" prop4+  , testProperty "bytestring builder" prop5   ]  prop1 ∷ [Action] → Property@@ -135,3 +146,51 @@     f1, f2 :: Buffer ⊸ Buffer     f1 = \b → addr# <|# interpretOnBuffer acts b     f2 = \b → T.pack "foo" <| interpretOnBuffer acts b++prop5 ∷ [Action] → Property+prop5 acts = T.encodeUtf8 (interpretOnText acts mempty) ===+  runBufferBS (\b → interpretOnBuffer acts b)++-------------------------------------------------------------------------------++newtype Int30 = Int30' Int+  deriving stock (Eq, Ord, Show)+  deriving newtype (Enum, Real, Integral)++pattern Int30 :: Int -> Int30+pattern Int30 x <- Int30' x where+  Int30 x = Int30' (x .&. ((1 `shiftL` 30) - 1))+{-# COMPLETE Int30 #-}++instance Arbitrary Int30 where+  arbitrary = Int30 <$> arbitrary+  shrink (Int30 x) = Int30 <$> shrink x++instance Bounded Int30 where+  minBound = negate (1 `shiftL` 30)+  maxBound = (1 `shiftL` 30) - 1++instance Num Int30 where+  Int30 x + Int30 y = Int30 (x + y)+  Int30 x * Int30 y = Int30 (x * y)+  abs (Int30 x) = Int30 (abs x)+  signum = undefined+  negate  (Int30 x) = Int30 (negate x)+  fromInteger x = Int30 (fromInteger x)++instance Bits Int30 where+  (.&.) = undefined+  (.|.) = undefined+  xor = undefined+  complement = undefined+  shift (Int30 x) i = Int30 (shift x i)+  rotate = undefined+  bitSize = const 30+  bitSizeMaybe = const (Just 30)+  isSigned = const True+  testBit = undefined+  bit = undefined+  popCount = undefined++instance FiniteBits Int30 where+  finiteBitSize = const 30
text-builder-linear.cabal view
@@ -1,89 +1,89 @@-cabal-version:      2.4-name:               text-builder-linear-version:            0.1-license: BSD-3-Clause-license-file: LICENSE-copyright: 2022 Andrew Lelechenko-author: Andrew Lelechenko-maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>-homepage: https://github.com/Bodigrim/linear-builder-category: Text-synopsis: Builder for Text based on linear types+cabal-version:   2.4+name:            text-builder-linear+version:         0.1.1+license:         BSD-3-Clause+license-file:    LICENSE+copyright:       2022 Andrew Lelechenko+maintainer:      Andrew Lelechenko <andrew.lelechenko@gmail.com>+author:          Andrew Lelechenko+tested-with:     ghc ==9.2.7 ghc ==9.4.4 ghc ==9.6.1+homepage:        https://github.com/Bodigrim/linear-builder+synopsis:        Builder for Text and ByteString based on linear types description:-  Strict Text builder, which hides mutable buffer behind linear types-  and takes amortized linear time.-extra-source-files: changelog.md README.md-tested-with: GHC == 9.0.2, GHC == 9.2.2+    Strict Text and ByteString builder, which hides mutable buffer behind linear types+    and takes amortized linear time. +category:        Text+extra-doc-files:+    changelog.md+    README.md+ source-repository head-  type: git-  location: git://github.com/Bodigrim/linear-builder.git+    type:     git+    location: git://github.com/Bodigrim/linear-builder.git -common stanza-  build-depends:    base >= 4.15 && < 5, text >= 2.0-  default-language: Haskell2010-  ghc-options: -Wall-  default-extensions:-    BangPatterns-    CPP-    DeriveGeneric-    GADTs-    KindSignatures-    LambdaCase-    LinearTypes-    MagicHash-    NumDecimals-    RankNTypes-    ScopedTypeVariables-    UnboxedTuples-    UnicodeSyntax-    ViewPatterns-  if impl(ghc >= 9.2)+library+    exposed-modules:+        Data.Text.Builder.Linear+        Data.Text.Builder.Linear.Buffer+        Data.Text.Builder.Linear.Core++    hs-source-dirs:     src+    other-modules:+        Data.Text.Builder.Linear.Char+        Data.Text.Builder.Linear.Dec+        Data.Text.Builder.Linear.Double+        Data.Text.Builder.Linear.Hex++    default-language:   GHC2021     default-extensions:-      UnliftedDatatypes+        LinearTypes MagicHash NumDecimals UnboxedTuples UnicodeSyntax+        UnliftedDatatypes ViewPatterns -library-  import: stanza-  build-depends: bytestring >= 0.10.12, quote-quot >= 0.2.1-  hs-source-dirs:   src-  ghc-options: -O2 -fexpose-all-unfoldings-  exposed-modules:-    Data.Text.Builder.Linear-    Data.Text.Builder.Linear.Buffer-    Data.Text.Builder.Linear.Core-  other-modules:-    Data.Text.Builder.Linear.Char-    Data.Text.Builder.Linear.Dec-    Data.Text.Builder.Linear.Double-    Data.Text.Builder.Linear.Hex+    ghc-options:        -Wall -O2 -fexpose-all-unfoldings+    build-depends:+        base >=4.16 && <5,+        text >=2.0 && <2.1,+        bytestring >=0.11 && <0.12,+        quote-quot >=0.2.1 && <0.3  test-suite linear-builder-tests-  import: stanza-  type: exitcode-stdio-1.0-  main-is: Main.hs-  build-depends:-    text-builder-linear,-    tasty,-    tasty-quickcheck-  hs-source-dirs: test-  ghc-options: -Wno-orphans -threaded -rtsopts "-with-rtsopts -N"+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     test+    default-language:   GHC2021+    default-extensions:+        DerivingStrategies LinearTypes MagicHash PatternSynonyms+        UnboxedTuples UnicodeSyntax +    ghc-options:+        -Wall -Wno-orphans -threaded -rtsopts "-with-rtsopts -N"++    build-depends:+        base,+        text,+        text-builder-linear,+        tasty >=1.4 && <1.5,+        tasty-quickcheck >=0.10 && <0.11+ benchmark linear-builder-bench-  import: stanza-  type: exitcode-stdio-1.0-  main-is: Main.hs-  other-modules:-    BenchChar-    BenchDecimal-    BenchDouble-    BenchHexadecimal-    BenchText-  hs-source-dirs: bench-  ghc-options: -rtsopts-  build-depends:-    text-builder-linear,-    -- text-builder,-    tasty,-    tasty-bench >= 0.3-  default-language: Haskell2010-  ghc-options: -O2+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     bench+    other-modules:+        BenchChar+        BenchDecimal+        BenchDouble+        BenchHexadecimal+        BenchText++    default-language:   GHC2021+    default-extensions: CPP LinearTypes NumDecimals UnicodeSyntax+    ghc-options:        -Wall -rtsopts -O2 -fproc-alignment=64+    build-depends:+        base,+        bytestring,+        text,+        text-builder-linear,+        tasty,+        tasty-bench >=0.3.2 && <0.4