diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrew Lelechenko (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Lelechenko nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,119 @@ +# 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) + +_Linear types for linear times!_ + +Builder for strict `Text`, based on linear types. It's consistently +outperforms lazy `Builder` from `text` as well as a strict builder from `text-builder`, +and scales better. + +## Example + +```haskell +> :set -XOverloadedStrings +> import Data.Text.Builder.Linear +> fromText "foo" <> fromChar '_' <> fromDec (42 :: Int) +"foo_42" +``` + +## Design + +String builders in Haskell serve the same purpose as `StringBuilder` in Java to prevent +quadratic slow down in concatenation. + +Classic builders such as `Data.Text.Lazy.Builder` are lazy and fundamentally are +[`dlist`](https://hackage.haskell.org/package/dlist) with bells and whistles: +instead of actually concatenating substrings we compose actions, which implement +concatenation, building a tree of thunks. The tree can be forced partially, left-to-right, +producing chunks of strict `Text`, combined into a lazy one. Neither input, nor output need to be materialized in full, which potentially allows for fusion. Such builders allow +linear time complexity, but constant factors are relatively high, because thunks are +expensive. To a certain degree this is mitigated by inlining, which massively reduces +number of nodes. + +Strict builders such as [`text-builder`](https://hackage.haskell.org/package/text-builder) +offer another design: they first inspect their input in full to determine output length, +then allocate a buffer of required size and fill it in one go. If everything inlines nicely, +the length may be known in compile time, which gives blazingly fast runtime. In more +complex cases it still builds a tree of thunks and forces all inputs to be materialized. + +This package offers two interfaces. One is a mutable `Buffer` with linear API, +which operates very similar to `StringBuilder` in Java. It allocates a buffer +with extra space at the ends to append new strings. If there is not enough free space +to insert new data, it allocates a twice larger buffer and copies itself there. +The dispatch happens in runtime, so we do not need to inspect and materialize all inputs +beforehand; and inlining is mostly irrelevant. +Exponential growth provides for amortized linear time. +Such structure can be implemented without linear types, but that would +greatly affect user experience by polluting everything with `ST` monad. +Users are encouraged to use `Buffer` API, and built-in benchmarks refer to it. + +The second interface is more traditional `newtype Builder = Builder (Buffer ⊸ Buffer)` +with `Monoid` instance. This type provides easy migration from other builders, +but may suffer from insufficient inlining, allocating a tree of thunks. It is still +significantly faster than `Data.Text.Lazy.Builder`, as witnessed by benchmarks +for `blaze-builder` below. + +## Benchmarks + +|Group / size|`text`|`text-builder`|Ratio|This package|Ratio| +|------------|-----:|-------------:|-:|-----------:|-:| +| **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| +| **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| +| **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| +| **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| +| **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| + +If you are not convinced by synthetic data, +here are benchmarks for +[`blaze-markup` after migration to `Data.Text.Builder.Linear`](https://github.com/Bodigrim/blaze-markup): + +``` +bigTable + 992 μs ± 80 μs, 49% less than baseline +basic + 4.35 μs ± 376 ns, 47% less than baseline +wideTree + 1.26 ms ± 85 μs, 53% less than baseline +wideTreeEscaping + 217 μs ± 7.8 μs, 58% less than baseline +deepTree + 242 μs ± 23 μs, 48% less than baseline +manyAttributes + 811 μs ± 79 μs, 58% less than baseline +customAttribute + 1.68 ms ± 135 μs, 56% less than baseline +``` diff --git a/bench/BenchChar.hs b/bench/BenchChar.hs new file mode 100644 --- /dev/null +++ b/bench/BenchChar.hs @@ -0,0 +1,50 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +module BenchChar (benchChar) where + +import Data.Char +import qualified Data.Text as T +import Data.Text.Builder.Linear.Buffer +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText, singleton) +import Test.Tasty.Bench + +#ifdef MIN_VERSION_text_builder +import qualified Text.Builder +#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) + +#ifdef MIN_VERSION_text_builder +benchStrictBuilder ∷ Int → T.Text +benchStrictBuilder = Text.Builder.run . go mempty + where + go !acc 0 = acc + go !acc n = let ch = chr n in go (Text.Builder.char ch <> (acc <> Text.Builder.char ch)) (n - 1) +#endif + +benchLinearBuilder ∷ Int → T.Text +benchLinearBuilder m = runBuffer (\b → go b m) + where + go ∷ Buffer ⊸ Int → Buffer + go !acc 0 = acc + go !acc n = let ch = chr n in go (ch .<| (acc |>. ch)) (n - 1) + +benchChar ∷ Benchmark +benchChar = bgroup "Char" $ map mkGroup [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6] + +mkGroup :: Int → Benchmark +mkGroup n = bgroup (show n) + [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n +#ifdef MIN_VERSION_text_builder + , bench "Text.Builder" $ nf benchStrictBuilder n +#endif + , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n + ] diff --git a/bench/BenchDecimal.hs b/bench/BenchDecimal.hs new file mode 100644 --- /dev/null +++ b/bench/BenchDecimal.hs @@ -0,0 +1,53 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +module BenchDecimal (benchDecimal) where + +import qualified Data.Text as T +import Data.Text.Builder.Linear.Buffer +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (decimal) +import Test.Tasty.Bench + +#ifdef MIN_VERSION_text_builder +import qualified Text.Builder +#endif + +int :: Int +int = 123456789123456789 + +benchLazyBuilder ∷ Int → T.Text +benchLazyBuilder = toStrict . toLazyText . go mempty + where + go !acc 0 = acc + go !acc n = let i = n * int in go (decimal i <> (acc <> decimal i)) (n - 1) + +#ifdef MIN_VERSION_text_builder +benchStrictBuilder ∷ Int → T.Text +benchStrictBuilder = Text.Builder.run . go mempty + where + go !acc 0 = acc + go !acc n = let i = n * int in go (Text.Builder.decimal i <> (acc <> Text.Builder.decimal i)) (n - 1) +#endif + +benchLinearBuilder ∷ Int → T.Text +benchLinearBuilder m = runBuffer (\b → go b m) + where + go ∷ Buffer ⊸ Int → Buffer + go !acc 0 = acc + go !acc n = let i = n * int in go (i $<| (acc |>$ i)) (n - 1) + +benchDecimal ∷ Benchmark +benchDecimal = bgroup "Decimal" $ map mkGroup [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6] + +mkGroup :: Int → Benchmark +mkGroup n = bgroup (show n) + [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n +#ifdef MIN_VERSION_text_builder + , bench "Text.Builder" $ nf benchStrictBuilder n +#endif + , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n + ] diff --git a/bench/BenchDouble.hs b/bench/BenchDouble.hs new file mode 100644 --- /dev/null +++ b/bench/BenchDouble.hs @@ -0,0 +1,53 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +module BenchDouble (benchDouble) where + +import qualified Data.Text as T +import Data.Text.Builder.Linear.Buffer +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.RealFloat (realFloat) +import Test.Tasty.Bench + +#ifdef MIN_VERSION_text_builder +import qualified Text.Builder +#endif + +dbl :: Double +dbl = - pi * 1e300 + +benchLazyBuilder ∷ Int → T.Text +benchLazyBuilder = toStrict . toLazyText . go mempty + where + go !acc 0 = acc + go !acc n = let d = fromIntegral n * dbl in go (realFloat d <> (acc <> realFloat d)) (n - 1) + +#ifdef MIN_VERSION_text_builder +benchStrictBuilder ∷ Int → T.Text +benchStrictBuilder = Text.Builder.run . go mempty + where + go !acc 0 = acc + go !acc n = let d = fromIntegral n * dbl in go (Text.Builder.fixedDouble 17 d <> (acc <> Text.Builder.fixedDouble 17 d)) (n - 1) +#endif + +benchLinearBuilder ∷ Int → T.Text +benchLinearBuilder m = runBuffer (\b → go b m) + where + go ∷ Buffer ⊸ Int → Buffer + go !acc 0 = acc + go !acc n = let d = fromIntegral n * dbl in go (d %<| (acc |>% d)) (n - 1) + +benchDouble ∷ Benchmark +benchDouble = bgroup "Double" $ map mkGroup [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6] + +mkGroup :: Int → Benchmark +mkGroup n = bgroup (show n) + [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n +#ifdef MIN_VERSION_text_builder + , bench "Text.Builder" $ nf benchStrictBuilder n +#endif + , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n + ] diff --git a/bench/BenchHexadecimal.hs b/bench/BenchHexadecimal.hs new file mode 100644 --- /dev/null +++ b/bench/BenchHexadecimal.hs @@ -0,0 +1,53 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +module BenchHexadecimal (benchHexadecimal) where + +import qualified Data.Text as T +import Data.Text.Builder.Linear.Buffer +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (hexadecimal) +import Test.Tasty.Bench + +#ifdef MIN_VERSION_text_builder +import qualified Text.Builder +#endif + +word :: Word +word = 123456789123456789 + +benchLazyBuilder ∷ Int → T.Text +benchLazyBuilder = toStrict . toLazyText . go mempty + where + go !acc 0 = acc + go !acc n = let i = fromIntegral n * word in go (hexadecimal i <> (acc <> hexadecimal i)) (n - 1) + +#ifdef MIN_VERSION_text_builder +benchStrictBuilder ∷ Int → T.Text +benchStrictBuilder = Text.Builder.run . go mempty + where + go !acc 0 = acc + go !acc n = let i = fromIntegral n * word in go (Text.Builder.hexadecimal i <> (acc <> Text.Builder.hexadecimal i)) (n - 1) +#endif + +benchLinearBuilder ∷ Int → T.Text +benchLinearBuilder m = runBuffer (\b → go b m) + where + go ∷ Buffer ⊸ Int → Buffer + go !acc 0 = acc + go !acc n = let i = fromIntegral n * word in go (i &<| (acc |>& i)) (n - 1) + +benchHexadecimal ∷ Benchmark +benchHexadecimal = bgroup "Hexadecimal" $ map mkGroup [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6] + +mkGroup :: Int → Benchmark +mkGroup n = bgroup (show n) + [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n +#ifdef MIN_VERSION_text_builder + , bench "Text.Builder" $ nf benchStrictBuilder n +#endif + , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n + ] diff --git a/bench/BenchText.hs b/bench/BenchText.hs new file mode 100644 --- /dev/null +++ b/bench/BenchText.hs @@ -0,0 +1,54 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +module BenchText (benchText) where + +import qualified Data.Text as T +import Data.Text.Builder.Linear.Buffer +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText, fromText) +import Test.Tasty.Bench + +#ifdef MIN_VERSION_text_builder +import qualified Text.Builder +#endif + +txt ∷ T.Text +txt = T.pack "Haskell + Linear Types = ♡" + +benchLazyBuilder ∷ Int → T.Text +benchLazyBuilder = toStrict . toLazyText . go mempty + where + txtB = fromText 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 + where + txtB = Text.Builder.text 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 + go ∷ Buffer ⊸ Int → Buffer + go !acc 0 = acc + go !acc n = go (txt <| (acc |> txt)) (n - 1) + +benchText ∷ Benchmark +benchText = bgroup "Text" $ map mkGroup [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6] + +mkGroup :: Int → Benchmark +mkGroup n = bgroup (show n) + [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n +#ifdef MIN_VERSION_text_builder + , bench "Text.Builder" $ nf benchStrictBuilder n +#endif + , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n + ] diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,52 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +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 +import BenchDouble +import BenchHexadecimal +import BenchText + +main ∷ IO () +main = defaultMain $ map (mapLeafs addCompare) $ + [ benchText + , benchChar + , benchDecimal + , benchHexadecimal + , benchDouble + ] + +textBenchName :: String +textBenchName = "Data.Text.Lazy.Builder" + +addCompare :: ([String] -> Benchmark -> Benchmark) +addCompare (name : path) + | name /= textBenchName = bcompare (printAwkExpr (locateLeaf (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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +## 0.1 + +* Initial release. diff --git a/src/Data/Text/Builder/Linear.hs b/src/Data/Text/Builder/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Linear.hs @@ -0,0 +1,127 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko +-- +-- Builder for strict 'Text', based on linear types. It's 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 + +import Data.Bits (FiniteBits) +import Data.Text.Internal (Text(..)) +import GHC.Exts (IsString(..), Addr#) + +import Data.Text.Builder.Linear.Buffer + +-- | Thin wrapper over 'Buffer' with a handy 'Semigroup' instance. +-- +-- >>> :set -XOverloadedStrings -XMagicHash +-- >>> fromText "foo" <> fromChar '_' <> fromAddr "bar"# +-- "foo_bar" +-- +-- 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. +-- +-- 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 } + +-- | Run 'Builder' computation on an empty 'Buffer', returning 'Text'. +-- +-- >>> :set -XOverloadedStrings -XMagicHash +-- >>> runBuilder (fromText "foo" <> fromChar '_' <> fromAddr "bar"#) +-- "foo_bar" +-- +-- This function has a polymorphic arrow and thus can be used both in +-- usual and linear contexts. +-- +runBuilder :: forall m. Builder %m → Text +runBuilder (Builder f) = runBuffer f +{-# INLINE runBuilder #-} + +instance Show Builder where + show (Builder f) = show (runBuffer f) + +instance Semigroup Builder where + Builder f <> Builder g = Builder $ \b → g (f b) + {-# INLINE (<>) #-} + +instance Monoid Builder where + mempty = Builder (\b → b) + {-# INLINE mempty #-} + +instance IsString Builder where + fromString = fromText . fromString + {-# INLINE fromString #-} + +-- | Create 'Builder', containing a given 'Text'. +-- +-- >>> :set -XOverloadedStrings +-- >>> fromText "foo" <> fromText "bar" +-- "foobar" +-- +fromText :: Text → Builder +fromText x = Builder $ \b → b |> x +{-# INLINE fromText #-} + +-- | Create 'Builder', containing a given 'Char'. +-- +-- >>> fromChar 'x' <> fromChar 'y' +-- "xy" +-- +fromChar :: Char → Builder +fromChar x = Builder $ \b → b |>. x +{-# INLINE fromChar #-} + +-- | Create 'Builder', containing a null-terminated UTF-8 string, specified by 'Addr#'. +-- +-- >>> :set -XMagicHash +-- >>> fromAddr "foo"# <> fromAddr "bar"# +-- "foobar" +-- +fromAddr :: Addr# → Builder +fromAddr x = Builder $ \b → b |># x +{-# INLINE fromAddr #-} + +-- | Create 'Builder', containing decimal representation of a given number. +-- +-- >>> fromChar 'x' <> fromDec (123 :: Int) +-- "x123" +-- +fromDec :: (Integral a, FiniteBits a) => a → Builder +fromDec x = Builder $ \b → b |>$ x +{-# INLINE fromDec #-} + +-- | Create 'Builder', containing hexadecimal representation of a given number. +-- +-- >>> :set -XMagicHash +-- >>> fromAddr "0x"# <> fromHex (0x123def :: Int) +-- "0x123def" +-- +fromHex :: (Integral a, FiniteBits a) => a → Builder +fromHex x = Builder $ \b → b |>& x +{-# INLINE fromHex #-} + +-- | Create 'Builder', containing a given 'Double'. +-- +-- >>> :set -XMagicHash +-- >>> fromAddr "pi="# <> fromDouble pi +-- "pi=3.141592653589793" +-- +fromDouble :: Double → Builder +fromDouble x = Builder $ \b → b |>% x +{-# INLINE fromDouble #-} diff --git a/src/Data/Text/Builder/Linear/Buffer.hs b/src/Data/Text/Builder/Linear/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Linear/Buffer.hs @@ -0,0 +1,134 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko +-- +-- 'Buffer' for strict 'Text', based on linear types. + +module Data.Text.Builder.Linear.Buffer + ( Buffer + , runBuffer + , 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.Builder.Linear.Char +import Data.Text.Builder.Linear.Core +import Data.Text.Builder.Linear.Dec +import Data.Text.Builder.Linear.Double +import Data.Text.Builder.Linear.Hex + +-- | Append 'Text' suffix to a 'Buffer' by mutating it. +-- If a suffix is statically known, consider using '(|>#)' for optimal performance. +-- +-- >>> :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 + +-- | Prepend 'Text' prefix to a 'Buffer' by mutating it. +-- If a prefix is statically known, consider using '(<|#)' for optimal performance. +-- +-- >>> :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 + +-- | Append a null-terminated UTF-8 string +-- to a 'Buffer' by mutating it. E. g., +-- +-- >>> :set -XOverloadedStrings -XLinearTypes -XMagicHash +-- >>> runBuffer (\b -> b |># "foo"# |># "bar"#) +-- "foobar" +-- +-- The literal string must not contain zero bytes @\\0@, this condition is 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 + where + srcLen = I# (cstringLength# addr#) + +-- | Prepend a null-terminated UTF-8 string +-- to a 'Buffer' by mutating it. E. g., +-- +-- >>> :set -XOverloadedStrings -XLinearTypes -XMagicHash +-- >>> runBuffer (\b -> "foo"# <|# "bar"# <|# b) +-- "foobar" +-- +-- The literal string must not contain zero bytes @\\0@, this condition is not checked. +(<|#) ∷ Addr# → Buffer ⊸ Buffer +infixr 6 <|# +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 + +-- | 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 + +-- | This is just a normal 'Data.List.foldl'', but with a linear arrow +-- and potentially unlifted accumulator. +foldlIntoBuffer ∷ (Buffer ⊸ a → Buffer) → Buffer ⊸ [a] → Buffer +foldlIntoBuffer f = go + where + go !acc [] = acc + go !acc (x : xs) = go (f acc x) xs diff --git a/src/Data/Text/Builder/Linear/Char.hs b/src/Data/Text/Builder/Linear/Char.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Linear/Char.hs @@ -0,0 +1,68 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +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 GHC.ST (ST) + +import Data.Text.Builder.Linear.Core + +-- | Append 'Char' to a 'Buffer' by mutating it. +-- +-- >>> :set -XLinearTypes +-- >>> runBuffer (\b -> b |>. 'q' |>. 'w') +-- "qw" +-- +(|>.) ∷ Buffer ⊸ Char → Buffer +infixl 6 |>. +buffer |>. ch = appendBounded 4 (\dst dstOff → unsafeWrite dst dstOff ch) buffer + +-- | Prepend 'Char' to a 'Buffer' by mutating it. +-- +-- >>> :set -XLinearTypes +-- >>> runBuffer (\b -> 'q' .<| 'w' .<| b) +-- "qw" +-- +(.<|) ∷ Char → Buffer ⊸ Buffer +infixr 6 .<| +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 marr off c = case utf8Length c of + 1 → do + let n0 = fromIntegral (ord c) + A.unsafeWrite marr (off - 1) n0 + pure 1 + 2 → do + let (n0, n1) = ord2 c + A.unsafeWrite marr (off - 2) n0 + A.unsafeWrite marr (off - 1) n1 + pure 2 + 3 → do + let (n0, n1, n2) = ord3 c + A.unsafeWrite marr (off - 3) n0 + A.unsafeWrite marr (off - 2) n1 + A.unsafeWrite marr (off - 1) n2 + pure 3 + _ → do + let (n0, n1, n2, n3) = ord4 c + A.unsafeWrite marr (off - 4) n0 + A.unsafeWrite marr (off - 3) n1 + A.unsafeWrite marr (off - 2) n2 + A.unsafeWrite marr (off - 1) n3 + pure 4 diff --git a/src/Data/Text/Builder/Linear/Core.hs b/src/Data/Text/Builder/Linear/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Linear/Core.hs @@ -0,0 +1,271 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko +-- +-- 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 + +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) + +-- | Internally 'Buffer' is a mutable buffer. +-- If a client gets hold of a variable of type 'Buffer', +-- they'd be able to pass a mutable buffer to concurrent threads. +-- That's why API below is carefully designed to prevent such possibility: +-- 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@. +-- +-- >>> :set -XOverloadedStrings -XLinearTypes +-- >>> import Data.Text.Builder.Linear.Buffer +-- >>> runBuffer (\b -> '!' .<| "foo" <| (b |> "bar" |>. '.')) +-- "!foobar." +-- +-- 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, +-- 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. +-- Most likely, this is not the function you're looking for +-- and you need 'runBuffer' instead. +unBuffer ∷ Buffer ⊸ Text +unBuffer (Buffer x) = x + +-- | Run a linear function on an empty 'Buffer', producing '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. +-- +runBuffer ∷ (Buffer ⊸ Buffer) ⊸ Text +runBuffer f = unBuffer (f (Buffer mempty)) + +-- | Duplicate builder. Feel free to process results in parallel threads. +-- Similar to @Data.Unrestricted.Linear.Dupable@ from @linear-base@. +-- +-- It is a bit tricky to use because of +-- +-- of linear types with regards to @let@ and @where@. E. g., one cannot write +-- +-- > let (# b1, b2 #) = dupBuffer b in ("foo" <| b1) >< (b2 |> "bar") +-- +-- Instead write: +-- +-- >>> :set -XOverloadedStrings -XLinearTypes -XUnboxedTuples +-- >>> import Data.Text.Builder.Linear.Buffer +-- >>> 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, +-- 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@. +consumeBuffer ∷ Buffer ⊸ () +consumeBuffer Buffer{} = () + +-- | Erase buffer's content, replacing it with an empty 'Text'. +eraseBuffer ∷ Buffer ⊸ Buffer +eraseBuffer Buffer{} = Buffer 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. +byteSizeOfBuffer ∷ Buffer ⊸ (# Buffer, Word #) +byteSizeOfBuffer (Buffer t@(Text _ _ len)) = (# Buffer t, fromIntegral len #) + +-- | Return buffer's length in 'Char's (not in bytes). +-- This could be useful to implement @dropEndBuffer@ and @takeEndBuffer@, e. g., +-- +-- @ +-- import Data.Unrestricted.Linear +-- +-- dropEndBuffer :: Word -> Buffer %1 -> Buffer +-- dropEndBuffer n buf = +-- (\(# buf', len #) -> case move len of Ur len' -> takeBuffer (len' - n) buf') +-- (lengthOfBuffer buf) +-- @ +lengthOfBuffer ∷ Buffer ⊸ (# Buffer, Word #) +lengthOfBuffer (Buffer t) = (# Buffer t, fromIntegral (T.length t) #) + +-- | Slice 'Buffer' by dropping given number of 'Char's. +dropBuffer ∷ Word → Buffer ⊸ Buffer +dropBuffer nChar (Buffer t@(Text arr off len)) + | nByte <= 0 = Buffer (Text arr (off + len) 0) + | otherwise = Buffer (Text arr (off + nByte) (len - nByte)) + where + nByte = T.measureOff (fromIntegral nChar) t + +-- | Slice 'Buffer' by taking given number of 'Char's. +takeBuffer ∷ Word → Buffer ⊸ Buffer +takeBuffer nChar (Buffer t@(Text arr off _)) + | nByte <= 0 = Buffer t + | otherwise = Buffer (Text arr off nByte) + where + nByte = T.measureOff (fromIntegral nChar) t + +-- | Low-level routine to append data of unknown size to a 'Buffer'. +appendBounded + ∷ Int + -- ^ Upper bound for the number of bytes, written by an action + → (forall 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 +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 + srcLen ← appender newM (dstOff + dstLen) + new ← A.unsafeFreeze newM + pure $ Text new dstOff (dstLen + srcLen) +{-# INLINE appendBounded #-} + +-- | Low-level routine to append data of known size to a 'Buffer'. +appendExact + ∷ Int + -- ^ Exact number of bytes, written by an action + → (forall 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) +{-# 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) + -- ^ 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) + -- ^ 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) + | 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) +{-# 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 ()) + -- ^ 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) +{-# INLINE prependExact #-} + +unsafeThaw ∷ Array → ST s (MArray s) +unsafeThaw (ByteArray a) = ST $ \s# → + (# s#, MutableByteArray (unsafeCoerce# a) #) + +sizeofByteArray ∷ Array → Int +sizeofByteArray (ByteArray a) = I# (sizeofByteArray# a) + +-- | Concatenate two 'Buffer's, potentially mutating both of them. +-- +-- You likely need to use 'dupBuffer' to get hold on two builders at once: +-- +-- >>> :set -XOverloadedStrings -XLinearTypes -XUnboxedTuples +-- >>> 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 + rightFullLen = sizeofByteArray right + 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) diff --git a/src/Data/Text/Builder/Linear/Dec.hs b/src/Data/Text/Builder/Linear/Dec.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Linear/Dec.hs @@ -0,0 +1,134 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +{-# LANGUAGE TemplateHaskell #-} + +module Data.Text.Builder.Linear.Dec + ( (|>$) + , ($<|) + ) where + +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 GHC.Ptr (plusPtr) +import GHC.ST (ST) +import Numeric.QuoteQuot (assumeNonNegArg, astQuot, quoteAST, quoteQuot) + +import Data.Text.Builder.Linear.Core + +-- | Append decimal number. +(|>$) :: (Integral a, FiniteBits a) => Buffer ⊸ a → Buffer +infixl 6 |>$ +buffer |>$ n = appendBounded + (maxDecLen n) + (\dst dstOff → unsafeAppendDec dst dstOff n) + buffer +{-# INLINABLE (|>$) #-} + +-- | Prepend decimal number. +($<|) :: (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 ($<|) #-} + +-- | ceiling (fbs a * logBase 10 2) < ceiling (fbs a * 5 / 16) < 1 + floor (fbs a * 5 / 16) +maxDecLen :: FiniteBits a => a → Int +maxDecLen a + | isSigned a = 2 + (finiteBitSize a * 5) `shiftR` 4 + | otherwise = 1 + (finiteBitSize a * 5) `shiftR` 4 +{-# INLINABLE maxDecLen #-} + +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 + where + go :: (Integral a, FiniteBits a) => Int → a → Int + go acc k + | finiteBitSize k >= 32, 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#) + | otherwise = I# (l# >=# 10000#) + I# (l# >=# 1000#) + I# (l# >=# 100#) + I# (l# >=# 10#) +{-# INLINABLE exactDecLen #-} + +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 #-} + +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 + | n == 0 = do + A.unsafeWrite marr (off - 1) 0x30 >> pure 1 + | otherwise = go (off - 1) (abs n) >>= sign + where + sign o + | n > 0 = pure (off - o) + | otherwise = do + A.unsafeWrite marr (o - 1) 0x2d -- '-' + pure (off - o + 1) + + 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 + | otherwise = do + A.unsafeWrite marr o (fromIntegral (48 + k)) + pure o + + digits :: Addr# + digits = "00010203040506070809101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899"# +{-# INLINABLE unsafePrependDec #-} + +minBoundLastDigit :: FiniteBits a => a → Int +minBoundLastDigit a = case finiteBitSize a .&. 4 of + 0 → 8 + 1 → 6 + 2 → 2 + _ → 4 +{-# INLINABLE minBoundLastDigit #-} + +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)) + _ → a `quot` 100 + where + cast :: (Integral a, Integral b) => (b → b) → a + cast f = fromIntegral (f (fromIntegral a)) +{-# INLINABLE quot100 #-} + +quotBillion :: (Integral a, FiniteBits a) => a → a +quotBillion a = case (finiteBitSize a, isSigned a) of + (64, True) → cast $$(quoteAST $ assumeNonNegArg $ astQuot (1e9 :: Int64)) + (64, False) → cast $$(quoteQuot (1e9 :: Word64)) + (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 #-} diff --git a/src/Data/Text/Builder/Linear/Double.hs b/src/Data/Text/Builder/Linear/Double.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Linear/Double.hs @@ -0,0 +1,70 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +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.Word (Word8) +import GHC.Exts (Ptr(..)) +import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr, unsafeWithForeignPtr, ForeignPtr) +import GHC.IO (unsafeIOToST, unsafeSTToIO, unsafeDupablePerformIO) +import GHC.Ptr (minusPtr) +import GHC.ST (ST) + +import Data.Text.Builder.Linear.Core + +-- | Append double. +(|>%) :: Buffer ⊸ Double → Buffer +infixl 6 |>% +buffer |>% x = appendBounded + maxDblLen + (\dst dstOff → unsafeAppendDouble dst dstOff x) + buffer + +-- | Prepend double +(%<|) :: Double → Buffer ⊸ Buffer +infixr 6 %<| +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 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 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 = + unsafeDupablePerformIO . buildStepToFirstChunk . BBI.runBuilder . BB.doubleDec +{-# INLINE runDoubleBuilder #-} + +buildStepToFirstChunk :: BBI.BuildStep a → IO (ForeignPtr Word8, Int) +buildStepToFirstChunk = \step → BBI.newBuffer maxDblLen >>= fill step + where + fill !step (BBI.Buffer fpbuf br) = do + let doneH op' _ = pure (fpbuf, op' `minusPtr` unsafeForeignPtrToPtr fpbuf) + fullH _ _ nextStep = BBI.newBuffer maxDblLen >>= fill nextStep + res ← BBI.fillWithBuildStep step doneH fullH undefined br + touchForeignPtr fpbuf + return res + +maxDblLen :: Int +maxDblLen = 24 -- length (show (-1.0000000000000004e-308 :: Double)) diff --git a/src/Data/Text/Builder/Linear/Hex.hs b/src/Data/Text/Builder/Linear/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Linear/Hex.hs @@ -0,0 +1,67 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +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 GHC.ST (ST) + +import Data.Text.Builder.Linear.Core + +-- | Append hexadecimal number. +(|>&) :: (Integral a, FiniteBits a) => Buffer ⊸ a → Buffer +infixl 6 |>& +buffer |>& n = appendBounded + (finiteBitSize n `shiftR` 2) + (\dst dstOff → unsafeAppendHex dst dstOff n) + buffer +{-# INLINABLE (|>&) #-} + +-- | Prepend hexadecimal number. +(&<|) :: (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 (&<|) #-} + +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 #-} + +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 #-} + +lengthAsHex :: FiniteBits a => a → Int +lengthAsHex n = max1 $ (finiteBitSize n `shiftR` 2) - (countLeadingZeros n `shiftR` 2) +{-# INLINABLE lengthAsHex #-} + +-- Branchless equivalent for max 1 n. +max1 :: Int → Int +max1 n@(I# n#) = n `xor` I# (n# <=# 0#) + +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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,137 @@ +-- | +-- Copyright: (c) 2022 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko + +module Main where + +import Data.Foldable +import qualified Data.Text as T +import Data.Text.Builder.Linear.Buffer +import Data.Text.Internal (Text(..)) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) +import Data.Text.Lazy.Builder.RealFloat (realFloat) +import GHC.Generics +import Test.Tasty +import Test.Tasty.QuickCheck hiding ((><)) + +instance Arbitrary Text where + arbitrary = do + xs ← T.pack <$> arbitrary + d ← (`mod` (T.length xs + 1)) <$> arbitrary + pure $ T.drop d xs + shrink t@(Text arr off len) + = map (T.drop d . T.pack) (shrink ys) + ++ map (\d' → T.drop d' $ T.pack $ drop (d - d') ys) (shrink d) + where + xs = T.unpack t + ys = T.unpack (Text arr 0 (off + len)) + d = length ys - length xs + +data Action + = AppendText Text + | PrependText Text + | AppendChar Char + | PrependChar Char + | AppendHex Word + | PrependHex Word + | AppendDec Int + | PrependDec Int + | AppendDouble Double + | PrependDouble Double + | AppendSpaces Word + | PrependSpaces Word + deriving (Eq, Ord, Show, Generic) + +instance Arbitrary Action where + arbitrary = oneof + [ AppendText <$> arbitrary + , PrependText <$> arbitrary + , AppendChar <$> arbitraryUnicodeChar + , PrependChar <$> arbitraryUnicodeChar + , AppendHex <$> arbitraryBoundedIntegral + , PrependHex <$> arbitraryBoundedIntegral + , AppendDec <$> arbitraryBoundedIntegral + , PrependDec <$> arbitraryBoundedIntegral + , pure $ AppendHex minBound + , pure $ AppendHex maxBound + , pure $ AppendDec minBound + , pure $ AppendDec maxBound + , pure $ AppendDec 0 + , AppendDouble <$> arbitrary + , PrependDouble <$> arbitrary + , AppendSpaces . getNonNegative <$> arbitrary + , PrependSpaces . getNonNegative <$> arbitrary + ] + shrink = genericShrink + +interpretOnText ∷ [Action] → Text → Text +interpretOnText xs z = foldl' go z xs + where + go ∷ Text → Action → Text + go b (AppendText x) = b <> x + go b (PrependText x) = x <> b + go b (AppendChar x) = T.snoc b x + go b (PrependChar x) = T.cons x b + go b (AppendHex x) = b <> toStrict (toLazyText (hexadecimal x)) + 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 (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 ' ') + go b (PrependSpaces n) = T.replicate (fromIntegral n) (T.singleton ' ') <> b + +interpretOnBuffer ∷ [Action] → Buffer ⊸ Buffer +interpretOnBuffer xs z = foldlIntoBuffer go z xs + where + go ∷ Buffer ⊸ Action → Buffer + go b (AppendText x) = b |> x + go b (PrependText x) = x <| b + go b (AppendChar x) = b |>. x + go b (PrependChar x) = x .<| b + go b (AppendHex x) = b |>& x + go b (PrependHex x) = x &<| b + go b (AppendDec x) = b |>$ x + go b (PrependDec x) = x $<| b + go b (AppendDouble x) = b |>% x + go b (PrependDouble x) = x %<| b + go b (AppendSpaces n) = b |>… n + go b (PrependSpaces n) = n …<| b + +main ∷ IO () +main = defaultMain $ testGroup "All" + [ testProperty "sequence of actions" prop1 + , testProperty "two sequences of actions" prop2 + , testProperty "append addr#" prop3 + , testProperty "prepend addr#" prop4 + ] + +prop1 ∷ [Action] → Property +prop1 acts = interpretOnText acts mempty === + runBuffer (\b → interpretOnBuffer acts b) + +prop2 ∷ [Action] → [Action] → Property +prop2 acts1 acts2 = interpretOnText acts1 mempty <> interpretOnText acts2 mempty === + runBuffer (\b → go (dupBuffer b)) + where + go ∷ (# Buffer, Buffer #) ⊸ Buffer + go (# b1, b2 #) = interpretOnBuffer acts1 b1 >< interpretOnBuffer acts2 b2 + +prop3 :: [Action] → Property +prop3 acts = runBuffer f1 === runBuffer f2 + where + addr# = "foo"# + f1, f2 :: Buffer ⊸ Buffer + f1 = \b → interpretOnBuffer acts b |># addr# + f2 = \b → interpretOnBuffer acts b |> T.pack "foo" + +prop4 :: [Action] → Property +prop4 acts = runBuffer f1 === runBuffer f2 + where + addr# = "foo"# + f1, f2 :: Buffer ⊸ Buffer + f1 = \b → addr# <|# interpretOnBuffer acts b + f2 = \b → T.pack "foo" <| interpretOnBuffer acts b diff --git a/text-builder-linear.cabal b/text-builder-linear.cabal new file mode 100644 --- /dev/null +++ b/text-builder-linear.cabal @@ -0,0 +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 +homepage: https://github.com/Bodigrim/linear-builder +category: Text +synopsis: Builder for Text 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 + +source-repository head + 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) + default-extensions: + UnliftedDatatypes + +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 + +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" + +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