text-rope 0.2 → 0.3
raw patch · 22 files changed
+3857/−721 lines, 22 filesdep ~deepseqdep ~tastydep ~tasty-quickcheck
Dependency ranges changed: deepseq, tasty, tasty-quickcheck, text, vector
Files
- bench/Main.hs +108/−39
- bench/bench-utf8.txt +1844/−0
- cbits/utils.c +50/−0
- changelog.md +8/−0
- src/Data/Text/Lines.hs +1/−0
- src/Data/Text/Lines/Internal.hs +39/−0
- src/Data/Text/Mixed/Rope.hs +589/−0
- src/Data/Text/Rope.hs +136/−89
- src/Data/Text/Utf16/Lines.hs +1/−0
- src/Data/Text/Utf16/Rope.hs +137/−95
- src/Data/Text/Utf16/Rope/Mixed.hs +20/−480
- src/Data/Text/Utf8/Lines.hs +196/−0
- src/Data/Text/Utf8/Rope.hs +417/−0
- test/CharLines.hs +11/−2
- test/CharRope.hs +13/−2
- test/Main.hs +4/−0
- test/MixedRope.hs +36/−2
- test/Utf16Rope.hs +13/−2
- test/Utf8Lines.hs +118/−0
- test/Utf8Rope.hs +67/−0
- test/Utils.hs +34/−2
- text-rope.cabal +15/−8
bench/Main.hs view
@@ -4,6 +4,7 @@ -- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -29,7 +30,9 @@ import Test.Tasty.Bench (defaultMain, bgroup, bench, nf, bcompare) import qualified Data.Text.Rope as CharRope+import qualified Data.Text.Utf8.Rope as Utf8Rope import qualified Data.Text.Utf16.Rope as Utf16Rope+import qualified Data.Text.Mixed.Rope as Mixed #ifdef MIN_VERSION_core_text import qualified Core.Text.Rope as CoreText #endif@@ -40,43 +43,59 @@ import qualified Yi.Rope as YiRope #endif +data CodePoint+data Utf8+data Utf16+ main :: IO () main = defaultMain [ bgroup "Split at position" [ bgroup "Unicode"- [ bench "text-rope" $ nf (editByPosition (Proxy @CharRope.Rope)) txt+ [ bench "text-rope" $ nf (editByPosition (Proxy @CodePoint) (Proxy @CharRope.Rope)) txt+ , bench "text-rope-mixed" $ nf (editByPosition (Proxy @CodePoint) (Proxy @Mixed.Rope)) txt #ifdef MIN_VERSION_yi_rope , bcompare "$NF == \"text-rope\" && $(NF-1) == \"Unicode\" && $(NF-2) == \"Split at position\""- $ bench "yi-rope" $ nf (editByPosition (Proxy @YiRope.YiString)) txt+ $ bench "yi-rope" $ nf (editByPosition (Proxy @CodePoint) (Proxy @YiRope.YiString)) txt #endif ] , bgroup "UTF-16"- [ bench "text-rope" $ nf (editByPosition (Proxy @Utf16Rope.Rope)) txt+ [ bench "text-rope" $ nf (editByPosition (Proxy @Utf16) (Proxy @Utf16Rope.Rope)) txt+ , bench "text-rope-mixed" $ nf (editByPosition (Proxy @Utf16) (Proxy @Mixed.Rope)) txt #ifdef MIN_VERSION_rope_utf16_splay , bcompare "$NF == \"text-rope\" && $(NF-1) == \"UTF-16\" && $(NF-2) == \"Split at position\""- $ bench "rope-utf16-splay" $ nf (editByPosition (Proxy @RopeSplay.Rope)) txt+ $ bench "rope-utf16-splay" $ nf (editByPosition (Proxy @Utf16) (Proxy @RopeSplay.Rope)) txt #endif ]+ , bgroup "UTF-8"+ [ bench "text-rope" $ nf (editByPosition (Proxy @Utf8) (Proxy @Utf8Rope.Rope)) txtUtf8+ , bench "text-rope-mixed" $ nf (editByPosition (Proxy @Utf8) (Proxy @Mixed.Rope)) txtUtf8+ ] ] , bgroup "Split at offset" [ bgroup "Unicode"- [ bench "text-rope" $ nf (editByOffset (Proxy @CharRope.Rope)) txt+ [ bench "text-rope" $ nf (editByOffset (Proxy @CodePoint) (Proxy @CharRope.Rope)) txt+ , bench "text-rope-mixed" $ nf (editByOffset (Proxy @CodePoint) (Proxy @Mixed.Rope)) txt #ifdef MIN_VERSION_core_text , bcompare "$NF == \"text-rope\" && $(NF-1) == \"Unicode\" && $(NF-2) == \"Split at offset\""- $ bench "core-text" $ nf (editByOffset (Proxy @CoreText.Rope)) txt+ $ bench "core-text" $ nf (editByOffset (Proxy @CodePoint) (Proxy @CoreText.Rope)) txt #endif #ifdef MIN_VERSION_yi_rope , bcompare "$NF == \"text-rope\" && $(NF-1) == \"Unicode\" && $(NF-2) == \"Split at offset\""- $ bench "yi-rope" $ nf (editByOffset (Proxy @YiRope.YiString)) txt+ $ bench "yi-rope" $ nf (editByOffset (Proxy @Utf16) (Proxy @YiRope.YiString)) txt #endif ] , bgroup "UTF-16"- [ bench "text-rope" $ nf (editByOffset (Proxy @Utf16Rope.Rope)) txt+ [ bench "text-rope" $ nf (editByOffset (Proxy @Utf16) (Proxy @Utf16Rope.Rope)) txt+ , bench "text-rope-mixed" $ nf (editByOffset (Proxy @Utf16) (Proxy @Mixed.Rope)) txt #ifdef MIN_VERSION_rope_utf16_splay , bcompare "$NF == \"text-rope\" && $(NF-1) == \"UTF-16\" && $(NF-2) == \"Split at offset\""- $ bench "rope-utf16-splay" $ nf (editByOffset (Proxy @RopeSplay.Rope)) txt+ $ bench "rope-utf16-splay" $ nf (editByOffset (Proxy @Utf16) (Proxy @RopeSplay.Rope)) txt #endif ]+ , bgroup "UTF-8"+ [ bench "text-rope" $ nf (editByOffset (Proxy @Utf8) (Proxy @Utf8Rope.Rope)) txtUtf8+ , bench "text-rope-mixed" $ nf (editByOffset (Proxy @Utf8) (Proxy @Mixed.Rope)) txtUtf8+ ] ] ] @@ -89,6 +108,12 @@ T.replicate scale <$> T.readFile fn {-# NOINLINE txt #-} +txtUtf8 :: T.Text+txtUtf8 = unsafePerformIO $ do+ fn <- getDataFileName "bench/bench-utf8.txt"+ T.replicate scale <$> T.readFile fn+{-# NOINLINE txtUtf8 #-}+ randomOffsets :: [Word] randomOffsets = take (1000 * scale) $ randomRs (0, fromIntegral $ T.length txt) (mkStdGen 33)@@ -102,76 +127,120 @@ cs = randomRs (0, 80) (mkStdGen 24) {-# NOINLINE randomPositions #-} -class Monoid a => Splittable a where+class Monoid a => Textable a where fromText :: T.Text -> a toText :: a -> T.Text- splitAt :: Word -> a -> (a, a) -class Splittable a => SplittableAtPosition a where- splitAtPosition :: Word -> Word -> a -> (a, a)+class Textable t => Splittable u t where+ splitAt :: Proxy u -> Word -> t -> (t, t) -instance Splittable CharRope.Rope where+class Splittable u t => SplittableAtPosition u t where+ splitAtPosition :: Proxy u -> Word -> Word -> t -> (t, t)++instance Textable CharRope.Rope where fromText = CharRope.fromText toText = CharRope.toText- splitAt = CharRope.splitAt -instance SplittableAtPosition CharRope.Rope where- splitAtPosition l c = CharRope.splitAtPosition (CharRope.Position l c)+instance Splittable CodePoint CharRope.Rope where+ splitAt _ = CharRope.splitAt -instance Splittable Utf16Rope.Rope where+instance SplittableAtPosition CodePoint CharRope.Rope where+ splitAtPosition _ l c = CharRope.splitAtPosition (CharRope.Position l c)++instance Textable Utf8Rope.Rope where+ fromText = Utf8Rope.fromText+ toText = Utf8Rope.toText++instance Splittable Utf8 Utf8Rope.Rope where+ splitAt _ = (fromJust . ) . Utf8Rope.splitAt++instance SplittableAtPosition Utf8 Utf8Rope.Rope where+ splitAtPosition _ l c = fromJust . Utf8Rope.splitAtPosition (Utf8Rope.Position l c)++instance Textable Utf16Rope.Rope where fromText = Utf16Rope.fromText toText = Utf16Rope.toText- splitAt = (fromJust . ) . Utf16Rope.splitAt -instance SplittableAtPosition Utf16Rope.Rope where- splitAtPosition l c = fromJust . Utf16Rope.splitAtPosition (Utf16Rope.Position l c)+instance Splittable Utf16 Utf16Rope.Rope where+ splitAt _ = (fromJust . ) . Utf16Rope.splitAt +instance SplittableAtPosition Utf16 Utf16Rope.Rope where+ splitAtPosition _ l c = fromJust . Utf16Rope.splitAtPosition (Utf16Rope.Position l c)++instance Textable Mixed.Rope where+ fromText = Mixed.fromText+ toText = Mixed.toText++instance Splittable CodePoint Mixed.Rope where+ splitAt _ = Mixed.charSplitAt++instance SplittableAtPosition CodePoint Mixed.Rope where+ splitAtPosition _ l c = Mixed.charSplitAtPosition (CharRope.Position l c)++instance Splittable Utf8 Mixed.Rope where+ splitAt _ = (fromJust . ) . Mixed.utf8SplitAt++instance SplittableAtPosition Utf8 Mixed.Rope where+ splitAtPosition _ l c = fromJust . Mixed.utf8SplitAtPosition (Utf8Rope.Position l c)++instance Splittable Utf16 Mixed.Rope where+ splitAt _ = (fromJust . ) . Mixed.utf16SplitAt++instance SplittableAtPosition Utf16 Mixed.Rope where+ splitAtPosition _ l c = fromJust . Mixed.utf16SplitAtPosition (Utf16Rope.Position l c)+ #ifdef MIN_VERSION_core_text-instance Splittable CoreText.Rope where+instance Textable CoreText.Rope where fromText = CoreText.intoRope toText = CoreText.fromRope- splitAt = CoreText.splitRope . fromIntegral++instance SplittableAtPosition CodePoint CoreText.Rope where+ splitAt _ = CoreText.splitRope . fromIntegral #endif #ifdef MIN_VERSION_yi_rope-instance Splittable YiRope.YiString where+instance Textable YiRope.YiString where fromText = YiRope.fromText toText = YiRope.toText- splitAt = YiRope.splitAt . fromIntegral -instance SplittableAtPosition YiRope.YiString where- splitAtPosition l c orig = (before `mappend` mid, after)+instance Splittable CodePoint YiRope.YiString where+ splitAt _ = YiRope.splitAt . fromIntegral++instance SplittableAtPosition CodePoint YiRope.YiString where+ splitAtPosition _ l c orig = (before `mappend` mid, after) where (before, after') = YiRope.splitAtLine (fromIntegral l) orig (mid, after) = YiRope.splitAt (fromIntegral c) after' #endif #ifdef MIN_VERSION_rope_utf16_splay-instance Splittable RopeSplay.Rope where+instance Textable RopeSplay.Rope where fromText = RopeSplay.fromText toText = RopeSplay.toText- splitAt = RopeSplay.splitAt . fromIntegral -instance SplittableAtPosition RopeSplay.Rope where- splitAtPosition l c orig = RopeSplay.splitAt k orig+instance Splittable Utf16 RopeSplay.Rope where+ splitAt _ = RopeSplay.splitAt . fromIntegral++instance SplittableAtPosition Utf16 RopeSplay.Rope where+ splitAtPosition _ l c orig = RopeSplay.splitAt k orig where k = RopeSplay.rowColumnCodeUnits (RopeSplay.RowColumn (fromIntegral l) (fromIntegral c)) orig #endif -editByOffset :: forall a. Splittable a => Proxy a -> T.Text -> T.Text-editByOffset _ txt = (toText @a) $ foldl' edit (fromText txt) randomOffsets+editByOffset :: forall u t. Splittable u t => Proxy u -> Proxy t -> T.Text -> T.Text+editByOffset _ _ txt = (toText @t) $ foldl' edit (fromText txt) randomOffsets where edit orig c = before `mappend` mid `mappend` after where- (before, after') = splitAt c orig+ (before, after') = splitAt (Proxy @u) c orig -- edit 10 characters- (mid, after) = splitAt 10 after'+ (mid, after) = splitAt (Proxy @u) 10 after' -editByPosition :: forall a. SplittableAtPosition a => Proxy a -> T.Text -> T.Text-editByPosition _ txt = (toText @a) $ foldl' edit (fromText txt) randomPositions+editByPosition :: forall u t. SplittableAtPosition u t => Proxy u -> Proxy t -> T.Text -> T.Text+editByPosition _ _ txt = (toText @t) $ foldl' edit (fromText txt) randomPositions where edit orig (l, c) = before `mappend` mid `mappend` after where- (before, after') = splitAtPosition l c orig+ (before, after') = splitAtPosition (Proxy @u) l c orig -- edit 10 characters- (mid, after) = splitAt 10 after'+ (mid, after) = splitAt (Proxy @u) 10 after'
+ bench/bench-utf8.txt view
@@ -0,0 +1,1844 @@+{- |+Module: Test.Tasty.Bench+Copyright: (c) 2021 Andrew Lelechenko+Licence: MIT++Featherlight benchmark framework (only one file!) for performance+measurement with API+mimicking [@criterion@](http://hackage.haskell.org/package/criterion)+and [@gauge@](http://hackage.haskell.org/package/gauge).+A prominent feature is built-in comparison against previous runs+and between benchmarks.++=== How lightweight is it?++There is only one source file "Test.Tasty.Bench" and no non-boot+dependencies except [@tasty@](http://hackage.haskell.org/package/tasty). So+if you already depend on @tasty@ for a test suite, there is nothing else+to install.++Compare this to @criterion@ (10+ modules, 50+ dependencies) and @gauge@+(40+ modules, depends on @basement@ and @vector@). A build on a clean machine is up to 16x+faster than @criterion@ and up to 4x faster than @gauge@. A build without dependencies+is up to 6x faster than @criterion@ and up to 8x faster than @gauge@.++@tasty-bench@ is a native Haskell library and works everywhere, where GHC+does. We support a full range of architectures (@i386@, @amd64@, @armhf@,+@arm64@, @ppc64le@, @s390x@) and operating systems (Linux, Windows, MacOS,+FreeBSD), plus any GHC from 7.0 to 9.2.++=== How is it possible?++Our benchmarks are literally regular @tasty@ tests, so we can leverage+all existing machinery for command-line options, resource management,+structuring, listing and filtering benchmarks, running and reporting+results. It also means that @tasty-bench@ can be used in conjunction+with other @tasty@ ingredients.++Unlike @criterion@ and @gauge@ we use a very simple statistical model+described below. This is arguably a questionable choice, but it works+pretty well in practice. A rare developer is sufficiently well-versed in+probability theory to make sense and use of all numbers generated by+@criterion@.++=== How to switch?++<https://cabal.readthedocs.io/en/3.4/cabal-package.html#pkg-field-mixins Cabal mixins>+allow to taste @tasty-bench@ instead of @criterion@ or @gauge@ without+changing a single line of code:++> cabal-version: 2.0+>+> benchmark foo+> ...+> build-depends:+> tasty-bench+> mixins:+> tasty-bench (Test.Tasty.Bench as Criterion, Test.Tasty.Bench as Criterion.Main, Test.Tasty.Bench as Gauge, Test.Tasty.Bench as Gauge.Main)++This works vice versa as well: if you use @tasty-bench@, but at some+point need a more comprehensive statistical analysis, it is easy to+switch temporarily back to @criterion@.++=== How to write a benchmark?++Benchmarks are declared in a separate section of @cabal@ file:++> cabal-version: 2.0+> name: bench-fibo+> version: 0.0+> build-type: Simple+> synopsis: Example of a benchmark+>+> benchmark bench-fibo+> main-is: BenchFibo.hs+> type: exitcode-stdio-1.0+> build-depends: base, tasty-bench+> ghc-options: "-with-rtsopts=-A32m"++And here is @BenchFibo.hs@:++> import Test.Tasty.Bench+>+> fibo :: Int -> Integer+> fibo n = if n < 2 then toInteger n else fibo (n - 1) + fibo (n - 2)+>+> main :: IO ()+> main = defaultMain+> [ bgroup "fibonacci numbers"+> [ bench "fifth" $ nf fibo 5+> , bench "tenth" $ nf fibo 10+> , bench "twentieth" $ nf fibo 20+> ]+> ]++Since @tasty-bench@ provides an API compatible with @criterion@, one can+refer to+<http://www.serpentine.com/criterion/tutorial.html#how-to-write-a-benchmark-suite its documentation>+for more examples.++=== How to read results?++Running the example above (@cabal@ @bench@ or @stack@ @bench@) results in+the following output:++> All+> fibonacci numbers+> fifth: OK (2.13s)+> 63 ns X 3.4 ns+> tenth: OK (1.71s)+> 809 ns X 73 ns+> twentieth: OK (3.39s)+> 104 Xs X 4.9 Xs+>+> All 3 tests passed (7.25s)++The output says that, for instance, the first benchmark was repeatedly+executed for 2.13 seconds (wall time), its predicted mean CPU time was+63 nanoseconds and means of individual samples do not often diverge from it+further than X3.4 nanoseconds (double standard deviation). Take standard+deviation numbers with a grain of salt; there are lies, damned lies, and+statistics.++=== Wall-clock time vs. CPU time++What time are we talking about?+Both @criterion@ and @gauge@ by default report wall-clock time, which is+affected by any other application which runs concurrently.+Ideally benchmarks are executed on a dedicated server without any other load,+but X let's face the truth X most of developers run benchmarks+on a laptop with a hundred other services and a window manager, and+watch videos while waiting for benchmarks to finish. That's the cause+of a notorious "variance introduced by outliers: 88% (severely inflated)" warning.++To alleviate this issue @tasty-bench@ measures CPU time by 'getCPUTime'+instead of wall-clock time.+It does not provide a perfect isolation from other processes (e. g.,+if CPU cache is spoiled by others, populating data back from RAM+is your burden), but is a bit more stable.++Caveat: this means that for multithreaded algorithms+@tasty-bench@ reports total elapsed CPU time across all cores, while+@criterion@ and @gauge@ print maximum of core's wall-clock time.+It also means that @tasty-bench@ cannot measure time spent out of process,+e. g., calls to other executables.++=== Statistical model++Here is a procedure used by @tasty-bench@ to measure execution time:++1. Set \( n \leftarrow 1 \).+2. Measure execution time \( t_n \) of \( n \) iterations and execution time+ \( t_{2n} \) of \( 2n \) iterations.+3. Find \( t \) which minimizes deviation of \( (nt, 2nt) \) from+ \( (t_n, t_{2n}) \), namely \( t \leftarrow (t_n + 2t_{2n}) / 5n \).+4. If deviation is small enough (see @--stdev@ below)+ or time is running out soon (see @--timeout@ below),+ return \( t \) as a mean execution time.+5. Otherwise set \( n \leftarrow 2n \) and jump back to Step 2.++This is roughly similar to the linear regression approach which+@criterion@ takes, but we fit only two last points. This allows us to+simplify away all heavy-weight statistical analysis. More importantly,+earlier measurements, which are presumably shorter and noisier, do not+affect overall result. This is in contrast to @criterion@, which fits+all measurements and is biased to use more data points corresponding to+shorter runs (it employs \( n \leftarrow 1.05n \) progression).++Mean time and its deviation does not say much about the+distribution of individual timings. E. g., imagine a computation which+(according to a coarse system timer) takes either 0 ms or 1 ms with equal+probability. While one would be able to establish that its mean time is 0.5 ms+with a very small deviation, this does not imply that individual measurements+are anywhere near 0.5 ms. Even assuming an infinite precision of a system+timer, the distribution of individual times is not known to be+<https://en.wikipedia.org/wiki/Normal_distribution normal>.++Obligatory disclaimer: statistics is a tricky matter, there is no+one-size-fits-all approach. In the absence of a good theory simplistic+approaches are as (un)sound as obscure ones. Those who seek statistical+soundness should rather collect raw data and process it themselves using+a proper statistical toolbox. Data reported by @tasty-bench@ is only of+indicative and comparative significance.++=== Memory usage++Configuring RTS to collect GC statistics+(e. g., via @cabal@ @bench@ @--benchmark-options@ @\'+RTS@ @-T\'@ or+@stack@ @bench@ @--ba@ @\'+RTS@ @-T\'@) enables @tasty-bench@ to estimate and+report memory usage:++> All+> fibonacci numbers+> fifth: OK (2.13s)+> 63 ns X 3.4 ns, 223 B allocated, 0 B copied, 2.0 MB peak memory+> tenth: OK (1.71s)+> 809 ns X 73 ns, 2.3 KB allocated, 0 B copied, 4.0 MB peak memory+> twentieth: OK (3.39s)+> 104 Xs X 4.9 Xs, 277 KB allocated, 59 B copied, 5.0 MB peak memory+>+> All 3 tests passed (7.25s)++This data is reported as per 'RTSStats' fields: 'allocated_bytes', 'copied_bytes'+and 'max_mem_in_use_bytes'.++=== Combining tests and benchmarks++When optimizing an existing function, it is important to check that its+observable behavior remains unchanged. One can rebuild both tests and+benchmarks after each change, but it would be more convenient to run+sanity checks within benchmark itself. Since our benchmarks are+compatible with @tasty@ tests, we can easily do so.++Imagine you come up with a faster function @myFibo@ to generate+Fibonacci numbers:++> import Test.Tasty.Bench+> import Test.Tasty.QuickCheck -- from tasty-quickcheck package+>+> fibo :: Int -> Integer+> fibo n = if n < 2 then toInteger n else fibo (n - 1) + fibo (n - 2)+>+> myFibo :: Int -> Integer+> myFibo n = if n < 3 then toInteger n else myFibo (n - 1) + myFibo (n - 2)+>+> main :: IO ()+> main = Test.Tasty.Bench.defaultMain -- not Test.Tasty.defaultMain+> [ bench "fibo 20" $ nf fibo 20+> , bench "myFibo 20" $ nf myFibo 20+> , testProperty "myFibo = fibo" $ \n -> fibo n === myFibo n+> ]++This outputs:++> All+> fibo 20: OK (3.02s)+> 104 Xs X 4.9 Xs+> myFibo 20: OK (1.99s)+> 71 Xs X 5.3 Xs+> myFibo = fibo: FAIL+> *** Failed! Falsified (after 5 tests and 1 shrink):+> 2+> 1 /= 2+> Use --quickcheck-replay=927711 to reproduce.+>+> 1 out of 3 tests failed (5.03s)++We see that @myFibo@ is indeed significantly faster than @fibo@, but+unfortunately does not do the same thing. One should probably look for+another way to speed up generation of Fibonacci numbers.++=== Troubleshooting++- If benchmarks take too long, set @--timeout@ to limit execution time+ of individual benchmarks, and @tasty-bench@ will do its best to fit+ into a given time frame. Without @--timeout@ we rerun benchmarks until+ achieving a target precision set by @--stdev@, which in a noisy+ environment of a modern laptop with GUI may take a lot of time.++ While @criterion@ runs each benchmark at least for 5 seconds,+ @tasty-bench@ is happy to conclude earlier, if it does not+ compromise the quality of results. In our experiments @tasty-bench@+ suites tend to finish earlier, even if some individual benchmarks+ take longer than with @criterion@.++ A common source of noisiness is garbage collection. Setting a larger+ allocation area (/nursery/) is often a good idea, either via+ @cabal@ @bench@ @--benchmark-options@ @\'+RTS@ @-A32m\'@ or+ @stack@ @bench@ @--ba@ @\'+RTS@ @-A32m\'@. Alternatively bake it into @cabal@+ file as @ghc-options:@ @\"-with-rtsopts=-A32m\"@.++ For GHC X 8.10 consider switching benchmarks to a non-moving garbage collector,+ because it decreases GC pauses and corresponding noise: @+RTS@ @--nonmoving-gc@.++- If benchmark results look malformed like below, make sure that you+ are invoking 'Test.Tasty.Bench.defaultMain' and not+ 'Test.Tasty.defaultMain' (the difference is 'consoleBenchReporter'+ vs.X'consoleTestReporter'):++ > All+ > fibo 20: OK (1.46s)+ > Response {respEstimate = Estimate {estMean = Measurement {measTime = 87496728, measAllocs = 0, measCopied = 0}, estStdev = 694487}, respIfSlower = FailIfSlower Infinity, respIfFaster = FailIfFaster Infinity}++- If benchmarks fail with an error message++ > Unhandled resource. Probably a bug in the runner you're using.++ or++ > Unexpected state of the resource (NotCreated) in getResource. Report as a tasty bug.++ this is likely caused by 'env' or 'envWithCleanup' affecting+ benchmarks structure. You can use 'env' to read test data from 'IO',+ but not to read benchmark names or affect their hierarchy in other+ way. This is a fundamental restriction of @tasty@ to list and filter+ benchmarks without launching missiles.++- If benchmarks fail with @Test dependencies form a loop@, this is likely+ because of 'bcompare', which compares a benchmark with itself.+ Locating a benchmark in a global environment may be tricky, please refer to+ [@tasty@ documentation](https://github.com/UnkindPartition/tasty#patterns) for details.++=== Isolating interfering benchmarks++One difficulty of benchmarking in Haskell is that it is hard to isolate+benchmarks so that they do not interfere. Changing the order of+benchmarks or skipping some of them has an effect on heapXs layout and+thus affects garbage collection. This issue is well attested in+<https://github.com/haskell/criterion/issues/166 both>+<https://github.com/haskell/criterion/issues/60 criterion> and+<https://github.com/vincenthz/hs-gauge/issues/2 gauge>.++Usually (but not always) skipping some benchmarks speeds up remaining+ones. ThatXs because once a benchmark allocated heap which for some+reason was not promptly released afterwards (e. g., it forced a+top-level thunk in an underlying library), all further benchmarks are+slowed down by garbage collector processing this additional amount of+live data over and over again.++There are several mitigation strategies. First of all, giving garbage+collector more breathing space by @+RTS@ @-A32m@ (or more) is often good+enough.++Further, avoid using top-level bindings to store large test data. Once+such thunks are forced, they remain allocated forever, which affects+detrimentally subsequent unrelated benchmarks. Treat them as external+data, supplied via 'env': instead of++> largeData :: String+> largeData = replicate 1000000 'a'+>+> main :: IO ()+> main = defaultMain+> [ bench "large" $ nf length largeData, ... ]++use++> import Control.DeepSeq (force)+> import Control.Exception (evaluate)+>+> main :: IO ()+> main = defaultMain+> [ env (evaluate (force (replicate 1000000 'a'))) $ \largeData ->+> bench "large" $ nf length largeData, ... ]++Finally, as an ultimate measure to reduce interference between+benchmarks, one can run each of them in a separate process. We do not+quite recommend this approach, but if you are desperate, here is how.++Assuming that a benchmark is declared in @cabal@ file as+@benchmark@ @my-bench@ component, letXs first find its executable:++> cabal build --enable-benchmarks my-bench+> MYBENCH=$(cabal list-bin my-bench) # available since cabal-3.4++Now list all benchmark names (hopefully, they do not contain newlines),+escape quotes and slashes, and run each of them separately:++> $MYBENCH -l | sed -e 's/[\"]/\\\\\\&/g' | while read -r name; do $MYBENCH -p '$0 == "'"$name"'"'; done++=== Comparison against baseline++One can compare benchmark results against an earlier baseline in an+automatic way. To use this feature, first run @tasty-bench@ with+@--csv@ @FILE@ key to dump results to @FILE@ in CSV format+(it could be a good idea to set smaller @--stdev@, if possible):++> Name,Mean (ps),2*Stdev (ps)+> All.fibonacci numbers.fifth,48453,4060+> All.fibonacci numbers.tenth,637152,46744+> All.fibonacci numbers.twentieth,81369531,3342646++Now modify implementation and rerun benchmarks with @--baseline@ @FILE@+key. This produces a report as follows:++> All+> fibonacci numbers+> fifth: OK (0.44s)+> 53 ns X 2.7 ns, 8% slower than baseline+> tenth: OK (0.33s)+> 641 ns X 59 ns+> twentieth: OK (0.36s)+> 77 Xs X 6.4 Xs, 5% faster than baseline+>+> All 3 tests passed (1.50s)++You can also fail benchmarks, which deviate too far from baseline, using+@--fail-if-slower@ and @--fail-if-faster@ options. For example, setting+both of them to 6 will fail the first benchmark above (because it is+more than 6% slower), but the last one still succeeds (even while it is+measurably faster than baseline, deviation is less than 6%). Consider+also using @--hide-successes@ to show only problematic benchmarks, or+even [@tasty-rerun@](http://hackage.haskell.org/package/tasty-rerun)+package to focus on rerunning failing items only.++If you wish to compare two CSV reports non-interactively, here is a handy @awk@ incantation:++> awk 'BEGIN{FS=",";OFS=",";print "Name,Old,New,Ratio"}FNR==1{next}FNR==NR{a[$1]=$2;next}{print $1,a[$1],$2,$2/a[$1];gs+=log($2/a[$1]);gc++}END{print "Geometric mean,,",exp(gs/gc)}' old.csv new.csv++Here is a larger snippet to compare two @git@ commits:++> compareBenches () {+> # compareBenches oldCommit newCommit <other arguments are passed to benchmarks directly>+> OLD="$1"+> shift+> NEW="$1"+> shift+> git checkout "$OLD"+> cabal run benchmarks -- --csv "$OLD".csv "$@"+> git checkout "$NEW"+> cabal run benchmarks -- --baseline "$OLD".csv --csv "$NEW".csv "$@"+> git checkout "@{\-2}"+> awk 'BEGIN{FS=",";OFS=",";print "Name,'"$OLD"','"$NEW"',Ratio"}FNR==1{next}FNR==NR{a[$1]=$2;next}{print $1,a[$1],$2,$2/a[$1];gs+=log($2/a[$1]);gc++}END{print "Geometric mean,,",exp(gs/gc)}' "$OLD".csv "$NEW".csv > "$OLD"-vs-"$NEW".csv+> }++Note that columns in CSV report are different from what @criterion@ or @gauge@+would produce. If names do not contain commas, missing columns can be faked this way:++> cat tasty-bench.csv | awk 'BEGIN {FS=",";OFS=","}; {print $1,$2/1e12,$2/1e12,$2/1e12,$3/2e12,$3/2e12,$3/2e12}' | sed '1s/.*/Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB/'++To fake @gauge@ in @--csvraw@ mode use++> cat tasty-bench.csv | awk 'BEGIN {FS=",";OFS=","}; {print $1,1,$2/1e12,0,$2/1e12,$2/1e12,0,$6+0,0,0,0,0,$4+0,0,$5+0,0,0,0,0}' | sed '1s/.*/name,iters,time,cycles,cpuTime,utime,stime,maxrss,minflt,majflt,nvcsw,nivcsw,allocated,numGcs,bytesCopied,mutatorWallSeconds,mutatorCpuSeconds,gcWallSeconds,gcCpuSeconds/'++Please refer to @gawk@ manual, if you wish to process names+with [commas](https://www.gnu.org/software/gawk/manual/gawk.html#Splitting-By-Content)+or [quotes](https://www.gnu.org/software/gawk/manual/gawk.html#More-CSV).++=== Comparison between benchmarks++You can also compare benchmarks to each other without reaching to+external tools, all in the comfort of your terminal.++> import Test.Tasty.Bench+>+> fibo :: Int -> Integer+> fibo n = if n < 2 then toInteger n else fibo (n - 1) + fibo (n - 2)+>+> main :: IO ()+> main = defaultMain+> [ bgroup "fibonacci numbers"+> [ bcompare "tenth" $ bench "fifth" $ nf fibo 5+> , bench "tenth" $ nf fibo 10+> , bcompare "tenth" $ bench "twentieth" $ nf fibo 20+> ]+> ]++This produces a report, comparing mean times of @fifth@ and @twentieth@+to @tenth@:++> All+> fibonacci numbers+> fifth: OK (16.56s)+> 121 ns X 2.6 ns, 0.08x+> tenth: OK (6.84s)+> 1.6 Xs X 31 ns+> twentieth: OK (6.96s)+> 203 Xs X 4.1 Xs, 128.36x++Locating a baseline benchmark in larger suites could get tricky;++> bcompare "$NF == \"tenth\" && $(NF-1) == \"fibonacci numbers\""++is a more robust choice of+an <https://github.com/UnkindPartition/tasty#patterns awk pattern> here.++One can leverage comparisons between benchmarks to implement portable performance+tests, expressing properties like "this algorithm must be at least twice faster+than that one" or "this operation should not be more than thrice slower than that".+This can be achieved with 'bcompareWithin', which takes an acceptable interval+of performance as an argument.++=== Plotting results++Users can dump results into CSV with @--csv@ @FILE@ and plot them using+@gnuplot@ or other software. But for convenience there is also a+built-in quick-and-dirty SVG plotting feature, which can be invoked by+passing @--svg@ @FILE@. Here is a sample of its output:++++=== Build flags++Build flags are a brittle subject and users do not normally need to touch them.++* If you find yourself in an environment, where @tasty@ is not available and you+ have access to boot packages only, you can still use @tasty-bench@! Just copy+ @Test\/Tasty\/Bench.hs@ to your project (imagine it like a header-only C library).+ It will provide you with functions to build 'Benchmarkable' and run them manually+ via 'measureCpuTime'. This mode of operation can be also configured+ by disabling Cabal flag @tasty@.++* If results are amiss or oscillate wildly and adjusting @--timeout@ and @--stdev@+ does not help, you may be interested to investigate individual timings of+ successive runs by enabling Cabal flag @debug@. This will pipe raw data into @stderr@.++=== Command-line options++Use @--help@ to list command-line options.++[@-p@, @--pattern@]:++ This is a standard @tasty@ option, which allows filtering benchmarks+ by a pattern or @awk@ expression. Please refer+ to [@tasty@ documentation](https://github.com/UnkindPartition/tasty#patterns)+ for details.++[@-t@, @--timeout@]:++ This is a standard @tasty@ option, setting timeout for individual+ benchmarks in seconds. Use it when benchmarks tend to take too long:+ @tasty-bench@ will make an effort to report results (even if of+ subpar quality) before timeout. Setting timeout too tight+ (insufficient for at least three iterations) will result in a+ benchmark failure. One can adjust it locally for a group+ of benchmarks, e. g., 'localOption' ('mkTimeout' 100000000) for 100 seconds.++[@--stdev@]:++ Target relative standard deviation of measurements in percents (5%+ by default). Large values correspond to fast and loose benchmarks,+ and small ones to long and precise.+ It can also be adjusted locally for a group of benchmarks,+ e. g., 'localOption' ('RelStDev' 0.02).+ If benchmarking takes far too long, consider setting @--timeout@,+ which will interrupt benchmarks,+ potentially before reaching the target deviation.++[@--csv@]:++ File to write results in CSV format.++[@--baseline@]:++ File to read baseline results in CSV format (as produced by+ @--csv@).++[@--fail-if-slower@, @--fail-if-faster@]:++ Upper bounds of acceptable slow down \/ speed up in percents. If a+ benchmark is unacceptably slower \/ faster than baseline (see+ @--baseline@), it will be reported as failed. Can be used in+ conjunction with a standard @tasty@ option @--hide-successes@ to+ show only problematic benchmarks.+ Both options can be adjusted locally for a group of benchmarks,+ e. g., 'localOption' ('FailIfSlower' 0.10).++[@--svg@]:++ File to plot results in SVG format.++[@+RTS@ @-T@]:++ Estimate and report memory usage.++=== Custom command-line options++As usual with @tasty@, it is easy to extend benchmarks with custom command-line options.+Here is an example:++> import Data.Proxy+> import Test.Tasty.Bench+> import Test.Tasty.Ingredients.Basic+> import Test.Tasty.Options+> import Test.Tasty.Runners+>+> newtype RandomSeed = RandomSeed Int+>+> instance IsOption RandomSeed where+> defaultValue = RandomSeed 42+> parseValue = fmap RandomSeed . safeRead+> optionName = pure "seed"+> optionHelp = pure "Random seed used in benchmarks"+>+> main :: IO ()+> main = do+> let customOpts = [Option (Proxy :: Proxy RandomSeed)]+> ingredients = includingOptions customOpts : benchIngredients+> opts <- parseOptions ingredients benchmarks+> let RandomSeed seed = lookupOption opts+> defaultMainWithIngredients ingredients benchmarks+>+> benchmarks :: Benchmark+> benchmarks = bgroup "All" []++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Test.Tasty.Bench+ (+#ifdef MIN_VERSION_tasty+ -- * Running 'Benchmark'+ defaultMain+ , Benchmark+ , bench+ , bgroup+#if MIN_VERSION_tasty(1,2,0)+ , bcompare+ , bcompareWithin+#endif+ , env+ , envWithCleanup+ ,+#endif+ -- * Creating 'Benchmarkable'+ Benchmarkable(..)+ , nf+ , whnf+ , nfIO+ , whnfIO+ , nfAppIO+ , whnfAppIO+ , measureCpuTime+#ifdef MIN_VERSION_tasty+ -- * Ingredients+ , benchIngredients+ , consoleBenchReporter+ , csvReporter+ , svgReporter+ , RelStDev(..)+ , FailIfSlower(..)+ , FailIfFaster(..)+ , CsvPath(..)+ , BaselinePath(..)+ , SvgPath(..)+#else+ , Timeout(..)+ , RelStDev(..)+#endif+ ) where++import Prelude hiding (Int, Integer)+import qualified Prelude+import Control.Applicative+import Control.Arrow (first, second)+import Control.DeepSeq (NFData, force)+import Control.Exception (bracket, evaluate)+import Control.Monad (void, unless, guard, (>=>), when)+import Data.Data (Typeable)+import Data.Foldable (foldMap, traverse_)+import Data.Int (Int64)+import Data.IORef+import Data.List (intercalate, stripPrefix, isPrefixOf, genericLength, genericDrop)+import Data.Monoid (All(..), Any(..))+import Data.Proxy+import Data.Traversable (forM)+import Data.Word (Word64)+import GHC.Conc+#if MIN_VERSION_base(4,5,0)+import GHC.IO.Encoding+#endif+#if MIN_VERSION_base(4,6,0)+import GHC.Stats+#endif+import System.CPUTime+import System.Exit+import System.IO+import System.IO.Unsafe+import System.Mem+import Text.Printf++#ifdef DEBUG+import Debug.Trace+#endif++#ifdef MIN_VERSION_tasty+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup(..))+#endif+#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as IM+#else+import qualified Data.IntMap as IM+#endif+import Data.IntMap (IntMap)+import Data.Sequence (Seq, (<|))+import qualified Data.Sequence as Seq+import qualified Data.Set as S+import Test.Tasty hiding (defaultMain)+import qualified Test.Tasty+import Test.Tasty.Ingredients+import Test.Tasty.Ingredients.ConsoleReporter+import Test.Tasty.Options+#if MIN_VERSION_tasty(1,2,0)+import Test.Tasty.Patterns.Eval (eval, asB, withFields)+import Test.Tasty.Patterns.Types (Expr (And, StringLit))+#endif+import Test.Tasty.Providers+import Test.Tasty.Runners+#endif++#ifndef MIN_VERSION_tasty+data Timeout+ = Timeout+ Prelude.Integer -- ^ number of microseconds (e. g., 200000)+ String -- ^ textual representation (e. g., @"0.2s"@)+ | NoTimeout+ deriving (Show)+#endif+++-- | In addition to @--stdev@ command-line option,+-- one can adjust target relative standard deviation+-- for individual benchmarks and groups of benchmarks+-- using 'adjustOption' and 'localOption'.+--+-- E. g., set target relative standard deviation to 2% as follows:+--+-- > import Test.Tasty (localOption)+-- > localOption (RelStDev 0.02) (bgroup [...])+--+-- If you set 'RelStDev' to infinity,+-- a benchmark will be executed+-- only once and its standard deviation will be recorded as zero.+-- This is rather a blunt approach, but it might be a necessary evil+-- for extremely long benchmarks. If you wish to run all benchmarks+-- only once, use command-line option @--stdev@ @Infinity@.+--+newtype RelStDev = RelStDev Double+ deriving (Show, Read, Typeable)++#ifdef MIN_VERSION_tasty+instance IsOption RelStDev where+ defaultValue = RelStDev 0.05+ parseValue = fmap RelStDev . parsePositivePercents+ optionName = pure "stdev"+ optionHelp = pure "Target relative standard deviation of measurements in percents (5 by default). Large values correspond to fast and loose benchmarks, and small ones to long and precise. If it takes far too long, consider setting --timeout, which will interrupt benchmarks, potentially before reaching the target deviation."++-- | In addition to @--fail-if-slower@ command-line option,+-- one can adjust an upper bound of acceptable slow down+-- in comparison to baseline for+-- individual benchmarks and groups of benchmarks+-- using 'adjustOption' and 'localOption'.+--+-- E. g., set upper bound of acceptable slow down to 10% as follows:+--+-- > import Test.Tasty (localOption)+-- > localOption (FailIfSlower 0.10) (bgroup [...])+--+newtype FailIfSlower = FailIfSlower Double+ deriving (Show, Read, Typeable)++instance IsOption FailIfSlower where+ defaultValue = FailIfSlower (1.0 / 0.0)+ parseValue = fmap FailIfSlower . parsePositivePercents+ optionName = pure "fail-if-slower"+ optionHelp = pure "Upper bound of acceptable slow down in percents. If a benchmark is unacceptably slower than baseline (see --baseline), it will be reported as failed."++-- | In addition to @--fail-if-faster@ command-line option,+-- one can adjust an upper bound of acceptable speed up+-- in comparison to baseline for+-- individual benchmarks and groups of benchmarks+-- using 'adjustOption' and 'localOption'.+--+-- E. g., set upper bound of acceptable speed up to 10% as follows:+--+-- > import Test.Tasty (localOption)+-- > localOption (FailIfFaster 0.10) (bgroup [...])+--+newtype FailIfFaster = FailIfFaster Double+ deriving (Show, Read, Typeable)++instance IsOption FailIfFaster where+ defaultValue = FailIfFaster (1.0 / 0.0)+ parseValue = fmap FailIfFaster . parsePositivePercents+ optionName = pure "fail-if-faster"+ optionHelp = pure "Upper bound of acceptable speed up in percents. If a benchmark is unacceptably faster than baseline (see --baseline), it will be reported as failed."++parsePositivePercents :: String -> Maybe Double+parsePositivePercents xs = do+ x <- safeRead xs+ guard (x > 0)+ pure (x / 100)+#endif++-- | Something that can be benchmarked, produced by 'nf', 'whnf', 'nfIO', 'whnfIO',+-- 'nfAppIO', 'whnfAppIO' below.+--+-- Drop-in replacement for @Criterion.@'Criterion.Benchmarkable' and+-- @Gauge.@'Gauge.Benchmarkable'.+--+newtype Benchmarkable = Benchmarkable+ { unBenchmarkable :: Word64 -> IO () -- ^ Run benchmark given number of times.+ } deriving (Typeable)++#ifdef MIN_VERSION_tasty++-- | 'defaultMain' forces 'setLocaleEncoding' to 'utf8', but users might+-- be running benchmarks outside of it (e. g., via 'defaultMainWithIngredients').+supportsUnicode :: Bool+#if MIN_VERSION_base(4,5,0)+supportsUnicode = take 3 (textEncodingName enc) == "UTF"+ where+ enc = unsafePerformIO getLocaleEncoding+#else+supportsUnicode = False+#endif+{-# NOINLINE supportsUnicode #-}++mu :: Char+mu = if supportsUnicode then 'X' else 'u'++pm :: String+pm = if supportsUnicode then " X " else " +-"++-- | Show picoseconds, fitting number in 3 characters.+showPicos3 :: Word64 -> String+showPicos3 i+ | t < 995 = printf "%3.0f ps" t+ | t < 995e1 = printf "%3.1f ns" (t / 1e3)+ | t < 995e3 = printf "%3.0f ns" (t / 1e3)+ | t < 995e4 = printf "%3.1f %cs" (t / 1e6) mu+ | t < 995e6 = printf "%3.0f %cs" (t / 1e6) mu+ | t < 995e7 = printf "%3.1f ms" (t / 1e9)+ | t < 995e9 = printf "%3.0f ms" (t / 1e9)+ | otherwise = printf "%4.2f s" (t / 1e12)+ where+ t = word64ToDouble i++-- | Show picoseconds, fitting number in 4 characters.+showPicos4 :: Word64 -> String+showPicos4 i+ | t < 995 = printf "%3.0f ps" t+ | t < 995e1 = printf "%4.2f ns" (t / 1e3)+ | t < 995e2 = printf "%4.1f ns" (t / 1e3)+ | t < 995e3 = printf "%3.0f ns" (t / 1e3)+ | t < 995e4 = printf "%4.2f %cs" (t / 1e6) mu+ | t < 995e5 = printf "%4.1f %cs" (t / 1e6) mu+ | t < 995e6 = printf "%3.0f %cs" (t / 1e6) mu+ | t < 995e7 = printf "%4.2f ms" (t / 1e9)+ | t < 995e8 = printf "%4.1f ms" (t / 1e9)+ | t < 995e9 = printf "%3.0f ms" (t / 1e9)+ | otherwise = printf "%4.3f s" (t / 1e12)+ where+ t = word64ToDouble i++showBytes :: Word64 -> String+showBytes i+ | t < 1000 = printf "%3.0f B " t+ | t < 10189 = printf "%3.1f KB" (t / 1024)+ | t < 1023488 = printf "%3.0f KB" (t / 1024)+ | t < 10433332 = printf "%3.1f MB" (t / 1048576)+ | t < 1048051712 = printf "%3.0f MB" (t / 1048576)+ | t < 10683731149 = printf "%3.1f GB" (t / 1073741824)+ | t < 1073204953088 = printf "%3.0f GB" (t / 1073741824)+ | t < 10940140696372 = printf "%3.1f TB" (t / 1099511627776)+ | t < 1098961871962112 = printf "%3.0f TB" (t / 1099511627776)+ | t < 11202704073084108 = printf "%3.1f PB" (t / 1125899906842624)+ | t < 1125336956889202624 = printf "%3.0f PB" (t / 1125899906842624)+ | t < 11471568970838126592 = printf "%3.1f EB" (t / 1152921504606846976)+ | otherwise = printf "%3.0f EB" (t / 1152921504606846976)+ where+ t = word64ToDouble i+#endif++data Measurement = Measurement+ { measTime :: !Word64 -- ^ time in picoseconds+ , measAllocs :: !Word64 -- ^ allocations in bytes+ , measCopied :: !Word64 -- ^ copied bytes+ , measMaxMem :: !Word64 -- ^ max memory in use+ } deriving (Show, Read)++data Estimate = Estimate+ { estMean :: !Measurement+ , estStdev :: !Word64 -- ^ stdev in picoseconds+ } deriving (Show, Read)++#ifdef MIN_VERSION_tasty++data WithLoHi a = WithLoHi+ !a -- payload+ !Double -- lower bound (e. g., 0.9 for -10% speedup)+ !Double -- upper bound (e. g., 1.2 for +20% slowdown)+ deriving (Show, Read)++prettyEstimate :: Estimate -> String+prettyEstimate (Estimate m stdev) =+ showPicos4 (measTime m)+ ++ (if stdev == 0 then " " else pm ++ showPicos3 (2 * stdev))++prettyEstimateWithGC :: Estimate -> String+prettyEstimateWithGC (Estimate m stdev) =+ showPicos4 (measTime m)+ ++ (if stdev == 0 then ", " else pm ++ showPicos3 (2 * stdev) ++ ", ")+ ++ showBytes (measAllocs m) ++ " allocated, "+ ++ showBytes (measCopied m) ++ " copied, "+ ++ showBytes (measMaxMem m) ++ " peak memory"++csvEstimate :: Estimate -> String+csvEstimate (Estimate m stdev) = show (measTime m) ++ "," ++ show (2 * stdev)++csvEstimateWithGC :: Estimate -> String+csvEstimateWithGC (Estimate m stdev) = show (measTime m) ++ "," ++ show (2 * stdev)+ ++ "," ++ show (measAllocs m) ++ "," ++ show (measCopied m) ++ "," ++ show (measMaxMem m)+#endif++predict+ :: Measurement -- ^ time for one run+ -> Measurement -- ^ time for two runs+ -> Estimate+predict (Measurement t1 a1 c1 m1) (Measurement t2 a2 c2 m2) = Estimate+ { estMean = Measurement t (fit a1 a2) (fit c1 c2) (max m1 m2)+ , estStdev = truncate (sqrt d :: Double)+ }+ where+ fit x1 x2 = x1 `quot` 5 + 2 * (x2 `quot` 5)+ t = fit t1 t2+ sqr x = x * x+ d = sqr (word64ToDouble t1 - word64ToDouble t)+ + sqr (word64ToDouble t2 - 2 * word64ToDouble t)++predictPerturbed :: Measurement -> Measurement -> Estimate+predictPerturbed t1 t2 = Estimate+ { estMean = estMean (predict t1 t2)+ , estStdev = max+ (estStdev (predict (lo t1) (hi t2)))+ (estStdev (predict (hi t1) (lo t2)))+ }+ where+ prec = max (fromInteger cpuTimePrecision) 1000000000 -- 1 ms+ hi meas = meas { measTime = measTime meas + prec }+ lo meas = meas { measTime = measTime meas - prec }++hasGCStats :: Bool+#if MIN_VERSION_base(4,10,0)+hasGCStats = unsafePerformIO getRTSStatsEnabled+#elif MIN_VERSION_base(4,6,0)+hasGCStats = unsafePerformIO getGCStatsEnabled+#else+hasGCStats = False+#endif++getAllocsAndCopied :: IO (Word64, Word64, Word64)+getAllocsAndCopied = do+ if not hasGCStats then pure (0, 0, 0) else+#if MIN_VERSION_base(4,10,0)+ (\s -> (allocated_bytes s, copied_bytes s, max_mem_in_use_bytes s)) <$> getRTSStats+#elif MIN_VERSION_base(4,6,0)+ (\s -> (int64ToWord64 $ bytesAllocated s, int64ToWord64 $ bytesCopied s, int64ToWord64 $ peakMegabytesAllocated s * 1024 * 1024)) <$> getGCStats+#else+ pure (0, 0, 0)+#endif++measure :: Word64 -> Benchmarkable -> IO Measurement+measure n (Benchmarkable act) = do+ performGC+ startTime <- fromInteger <$> getCPUTime+ (startAllocs, startCopied, startMaxMemInUse) <- getAllocsAndCopied+ act n+ endTime <- fromInteger <$> getCPUTime+ (endAllocs, endCopied, endMaxMemInUse) <- getAllocsAndCopied+ let meas = Measurement+ { measTime = endTime - startTime+ , measAllocs = endAllocs - startAllocs+ , measCopied = endCopied - startCopied+ , measMaxMem = max endMaxMemInUse startMaxMemInUse+ }+#ifdef DEBUG+ pure $ trace (show n ++ (if n == 1 then " iteration gives " else " iterations give ") ++ show meas) meas+#else+ pure meas+#endif++measureUntil :: Bool -> Timeout -> RelStDev -> Benchmarkable -> IO Estimate+measureUntil _ _ (RelStDev targetRelStDev) b+ | isInfinite targetRelStDev, targetRelStDev > 0 = do+ t1 <- measure 1 b+ pure $ Estimate { estMean = t1, estStdev = 0 }+measureUntil warnIfNoTimeout timeout (RelStDev targetRelStDev) b = do+ t1 <- measure 1 b+ go 1 t1 0+ where+ go :: Word64 -> Measurement -> Word64 -> IO Estimate+ go n t1 sumOfTs = do+ t2 <- measure (2 * n) b++ let Estimate (Measurement meanN allocN copiedN maxMemN) stdevN = predictPerturbed t1 t2+ isTimeoutSoon = case timeout of+ NoTimeout -> False+ -- multiplying by 12/10 helps to avoid accidental timeouts+ Timeout micros _ -> (sumOfTs' + 3 * measTime t2) `quot` (1000000 * 10 `quot` 12) >= fromInteger micros+ isStDevInTargetRange = stdevN < truncate (max 0 targetRelStDev * word64ToDouble meanN)+ scale = (`quot` n)+ sumOfTs' = sumOfTs + measTime t1++ case timeout of+ NoTimeout | warnIfNoTimeout, sumOfTs' + measTime t2 > 100 * 1000000000000+ -> hPutStrLn stderr "This benchmark takes more than 100 seconds. Consider setting --timeout, if this is unexpected (or to silence this warning)."+ _ -> pure ()++ if isStDevInTargetRange || isTimeoutSoon+ then pure $ Estimate+ { estMean = Measurement (scale meanN) (scale allocN) (scale copiedN) maxMemN+ , estStdev = scale stdevN }+ else go (2 * n) t2 sumOfTs'++-- | An internal routine to measure execution time in seconds+-- for a given timeout (put 'NoTimeout', or 'mkTimeout' 100000000 for 100 seconds)+-- and a target relative standard deviation+-- (put 'RelStDev' 0.05 for 5% or 'RelStDev' (1/0) to run only one iteration).+--+-- 'Timeout' takes soft priority over 'RelStDev': this function prefers+-- to finish in time even if at cost of precision. However, timeout is guidance+-- not guarantee: 'measureCpuTime' can take longer, if there is not enough time+-- to run at least thrice or an iteration takes unusually long.+measureCpuTime :: Timeout -> RelStDev -> Benchmarkable -> IO Double+measureCpuTime+ = ((fmap ((/ 1e12) . word64ToDouble . measTime . estMean) .) .)+ . measureUntil False++#ifdef MIN_VERSION_tasty++instance IsTest Benchmarkable where+ testOptions = pure+ [ Option (Proxy :: Proxy RelStDev)+ -- FailIfSlower and FailIfFaster must be options of a test provider rather+ -- than options of an ingredient to allow setting them on per-test level.+ , Option (Proxy :: Proxy FailIfSlower)+ , Option (Proxy :: Proxy FailIfFaster)+ ]+ run opts b = const $ case getNumThreads (lookupOption opts) of+ 1 -> do+ est <- measureUntil True (lookupOption opts) (lookupOption opts) b+ let FailIfSlower ifSlower = lookupOption opts+ FailIfFaster ifFaster = lookupOption opts+ pure $ testPassed $ show (WithLoHi est (1 - ifFaster) (1 + ifSlower))+ _ -> pure $ testFailed "Benchmarks must not be run concurrently. Please pass -j1 and/or avoid +RTS -N."++-- | Attach a name to 'Benchmarkable'.+--+-- This is actually a synonym of 'Test.Tasty.Providers.singleTest' to+-- provide an interface compatible with @Criterion.@'Criterion.bench'+-- and @Gauge.@'Gauge.bench'.+--+bench :: String -> Benchmarkable -> Benchmark+bench = singleTest++-- | Attach a name to a group of 'Benchmark'.+--+-- This is actually a synonym of 'Test.Tasty.testGroup' to provide an+-- interface compatible with @Criterion.@'Criterion.bgroup' and+-- @Gauge@.'Gauge.bgroup'.+--+bgroup :: String -> [Benchmark] -> Benchmark+bgroup = testGroup++#if MIN_VERSION_tasty(1,2,0)+-- | Compare benchmarks, reporting relative speed up or slow down.+--+-- This function is a vague reminiscence of @bcompare@, which existed in pre-1.0+-- versions of @criterion@, but their types are incompatible. Under the hood+-- 'bcompare' is a thin wrapper over 'after' and requires @tasty-1.2@.+--+bcompare+ :: String+ -- ^ @tasty@ pattern, which must unambiguously+ -- match a unique baseline benchmark. Locating a benchmark in a global environment+ -- may be tricky, please refer to+ -- [@tasty@ documentation](https://github.com/UnkindPartition/tasty#patterns) for details.+ -> Benchmark+ -- ^ Benchmark (or a group of benchmarks)+ -- to be compared against the baseline benchmark by dividing measured mean times.+ -- The result is reported by 'consoleBenchReporter', e. g., 0.50x or 1.25x.+ -> Benchmark+bcompare = bcompareWithin (-1/0) (1/0)++-- | Same as 'bcompare', but takes expected lower and upper bounds of+-- comparison. If the result is not within provided bounds, benchmark is failed.+-- This allows to create portable performance tests: instead of comparing+-- to an absolute timeout or to previous runs, you can state that one implementation+-- of an algorithm must be faster than another.+--+-- E. g., 'bcompareWithin' 2.0 3.0 passes only if a benchmark is at least 2x+-- and at most 3x slower than a baseline.+--+bcompareWithin+ :: Double -- ^ Lower bound of relative speed up.+ -> Double -- ^ Upper bound of relative spped up.+ -> String -- ^ @tasty@ pattern to locate a baseline benchmark.+ -> Benchmark -- ^ Benchmark to compare against baseline.+ -> Benchmark+bcompareWithin lo hi s = case parseExpr s of+ Nothing -> error $ "Could not parse bcompare pattern " ++ s+ Just e -> after_ AllSucceed (And (StringLit (bcomparePrefix ++ show (lo, hi))) e)++bcomparePrefix :: String+bcomparePrefix = "tasty-bench"+#endif++-- | Benchmarks are actually just a regular 'Test.Tasty.TestTree' in disguise.+--+-- This is a drop-in replacement for @Criterion.@'Criterion.Benchmark'+-- and @Gauge.@'Gauge.Benchmark'.+--+type Benchmark = TestTree++-- | Run benchmarks and report results, providing an interface+-- compatible with @Criterion.@'Criterion.defaultMain' and+-- @Gauge.@'Gauge.defaultMain'.+--+defaultMain :: [Benchmark] -> IO ()+defaultMain bs = do+#if MIN_VERSION_base(4,5,0)+ setLocaleEncoding utf8+#endif+ Test.Tasty.defaultMainWithIngredients benchIngredients $ testGroup "All" bs++-- | List of default benchmark ingredients. This is what 'defaultMain' runs.+--+benchIngredients :: [Ingredient]+benchIngredients = [listingTests, composeReporters consoleBenchReporter (composeReporters csvReporter svgReporter)]++#endif++funcToBench :: (b -> c) -> (a -> b) -> a -> Benchmarkable+funcToBench frc = (Benchmarkable .) . go+ where+ go f x n+ | n == 0 = pure ()+ | otherwise = do+ _ <- evaluate (frc (f x))+ go f x (n - 1)+{-# INLINE funcToBench #-}++-- | 'nf' @f@ @x@ measures time to compute+-- a normal form (by means of 'force') of an application of @f@ to @x@.+-- This does not include time to evaluate @f@ or @x@ themselves.+-- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.+--+-- The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate+-- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may+-- be an infinite structure. Thus @x@ will be evaluated in course of the first+-- application of @f@. This noisy measurement is to be discarded soon,+-- but if @x@ is not a primitive data type, consider forcing its evaluation+-- separately, e. g., via 'env' or 'withResource'.+--+-- Here is a textbook anti-pattern: 'nf' 'sum' @[1..1000000]@.+-- Since an input list is shared by multiple invocations of 'sum',+-- it will be allocated in memory in full, putting immense pressure+-- on garbage collector. Also no list fusion will happen.+-- A better approach is 'nf' (@\\n@ @->@ 'sum' @[1..n]@) @1000000@.+--+-- If you are measuring an inlinable function,+-- it is prudent to ensure that its invocation is fully saturated,+-- otherwise inlining will not happen. That's why one can often+-- see 'nf' (@\\n@ @->@ @f@ @n@) @x@ instead of 'nf' @f@ @x@.+-- Same applies to rewrite rules.+--+-- While @tasty-bench@ is capable to perform micro- and even nanobenchmarks,+-- such measurements are noisy and involve an overhead. Results are more reliable+-- when @f@ @x@ takes at least several milliseconds.+--+-- Note that forcing a normal form requires an additional+-- traverse of the structure. In certain scenarios (imagine benchmarking 'tail'),+-- especially when 'NFData' instance is badly written,+-- this traversal may take non-negligible time and affect results.+--+-- Drop-in replacement for @Criterion.@'Criterion.nf' and+-- @Gauge.@'Gauge.nf'.+--+nf :: NFData b => (a -> b) -> a -> Benchmarkable+nf = funcToBench force+{-# INLINE nf #-}++-- | 'whnf' @f@ @x@ measures time to compute+-- a weak head normal form of an application of @f@ to @x@.+-- This does not include time to evaluate @f@ or @x@ themselves.+-- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.+--+-- The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate+-- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may+-- be an infinite structure. Thus @x@ will be evaluated in course of the first+-- application of @f@. This noisy measurement is to be discarded soon,+-- but if @x@ is not a primitive data type, consider forcing its evaluation+-- separately, e. g., via 'env' or 'withResource'.+--+-- Computing only a weak head normal form is+-- rarely what intuitively is meant by "evaluation".+-- Beware that many educational materials contain examples with 'whnf':+-- this is a wrong default.+-- Unless you understand precisely, what is measured,+-- it is recommended to use 'nf' instead.+--+-- Here is a textbook anti-pattern: 'whnf' ('Data.List.replicate' @1000000@) @1@.+-- This will succeed in a matter of nanoseconds, because weak head+-- normal form forces only the first element of the list.+--+-- Drop-in replacement for @Criterion.@'Criterion.whnf' and @Gauge.@'Gauge.whnf'.+--+whnf :: (a -> b) -> a -> Benchmarkable+whnf = funcToBench id+{-# INLINE whnf #-}++ioToBench :: (b -> c) -> IO b -> Benchmarkable+ioToBench frc act = Benchmarkable go+ where+ go n+ | n == 0 = pure ()+ | otherwise = do+ val <- act+ _ <- evaluate (frc val)+ go (n - 1)+{-# INLINE ioToBench #-}++-- | 'nfIO' @x@ measures time to evaluate side-effects of @x@+-- and compute its normal form (by means of 'force').+--+-- Pure subexpression of an effectful computation @x@+-- may be evaluated only once and get cached.+-- To avoid surprising results it is usually preferable+-- to use 'nfAppIO' instead.+--+-- Note that forcing a normal form requires an additional+-- traverse of the structure. In certain scenarios,+-- especially when 'NFData' instance is badly written,+-- this traversal may take non-negligible time and affect results.+--+-- A typical use case is 'nfIO' ('readFile' @"foo.txt"@).+-- However, if your goal is not to benchmark I\/O per se,+-- but just read input data from a file, it is cleaner to+-- use 'env' or 'withResource'.+--+-- Drop-in replacement for @Criterion.@'Criterion.nfIO' and @Gauge.@'Gauge.nfIO'.+--+nfIO :: NFData a => IO a -> Benchmarkable+nfIO = ioToBench force+{-# INLINE nfIO #-}++-- | 'whnfIO' @x@ measures time to evaluate side-effects of @x@+-- and compute its weak head normal form.+--+-- Pure subexpression of an effectful computation @x@+-- may be evaluated only once and get cached.+-- To avoid surprising results it is usually preferable+-- to use 'whnfAppIO' instead.+--+-- Computing only a weak head normal form is+-- rarely what intuitively is meant by "evaluation".+-- Unless you understand precisely, what is measured,+-- it is recommended to use 'nfIO' instead.+--+-- Lazy I\/O is treacherous.+-- If your goal is not to benchmark I\/O per se,+-- but just read input data from a file, it is cleaner to+-- use 'env' or 'withResource'.+--+-- Drop-in replacement for @Criterion.@'Criterion.whnfIO' and @Gauge.@'Gauge.whnfIO'.+--+whnfIO :: IO a -> Benchmarkable+whnfIO = ioToBench id+{-# INLINE whnfIO #-}++ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Benchmarkable+ioFuncToBench frc = (Benchmarkable .) . go+ where+ go f x n+ | n == 0 = pure ()+ | otherwise = do+ val <- f x+ _ <- evaluate (frc val)+ go f x (n - 1)+{-# INLINE ioFuncToBench #-}++-- | 'nfAppIO' @f@ @x@ measures time to evaluate side-effects of+-- an application of @f@ to @x@.+-- and compute its normal form (by means of 'force').+-- This does not include time to evaluate @f@ or @x@ themselves.+-- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.+--+-- The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate+-- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may+-- be an infinite structure. Thus @x@ will be evaluated in course of the first+-- application of @f@. This noisy measurement is to be discarded soon,+-- but if @x@ is not a primitive data type, consider forcing its evaluation+-- separately, e. g., via 'env' or 'withResource'.+--+-- Note that forcing a normal form requires an additional+-- traverse of the structure. In certain scenarios,+-- especially when 'NFData' instance is badly written,+-- this traversal may take non-negligible time and affect results.+--+-- A typical use case is 'nfAppIO' 'readFile' @"foo.txt"@.+-- However, if your goal is not to benchmark I\/O per se,+-- but just read input data from a file, it is cleaner to+-- use 'env' or 'withResource'.+--+-- Drop-in replacement for @Criterion.@'Criterion.nfAppIO' and @Gauge.@'Gauge.nfAppIO'.+--+nfAppIO :: NFData b => (a -> IO b) -> a -> Benchmarkable+nfAppIO = ioFuncToBench force+{-# INLINE nfAppIO #-}++-- | 'whnfAppIO' @f@ @x@ measures time to evaluate side-effects of+-- an application of @f@ to @x@.+-- and compute its weak head normal form.+-- This does not include time to evaluate @f@ or @x@ themselves.+-- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.+--+-- The same thunk of @x@ is shared by multiple calls of @f@. We cannot evaluate+-- @x@ beforehand: there is no 'NFData' @a@ constraint, and potentially @x@ may+-- be an infinite structure. Thus @x@ will be evaluated in course of the first+-- application of @f@. This noisy measurement is to be discarded soon,+-- but if @x@ is not a primitive data type, consider forcing its evaluation+-- separately, e. g., via 'env' or 'withResource'.+--+-- Computing only a weak head normal form is+-- rarely what intuitively is meant by "evaluation".+-- Unless you understand precisely, what is measured,+-- it is recommended to use 'nfAppIO' instead.+--+-- Lazy I\/O is treacherous.+-- If your goal is not to benchmark I\/O per se,+-- but just read input data from a file, it is cleaner to+-- use 'env' or 'withResource'.+--+-- Drop-in replacement for @Criterion.@'Criterion.whnfAppIO' and @Gauge.@'Gauge.whnfAppIO'.+--+whnfAppIO :: (a -> IO b) -> a -> Benchmarkable+whnfAppIO = ioFuncToBench id+{-# INLINE whnfAppIO #-}++#ifdef MIN_VERSION_tasty++-- | Run benchmarks in the given environment, usually reading large input data from file.+--+-- One might wonder why 'env' is needed,+-- when we can simply read all input data+-- before calling 'defaultMain'. The reason is that large data+-- dangling in the heap causes longer garbage collection+-- and slows down all benchmarks, even those which do not use it at all.+--+-- It is instrumental not only for proper 'IO' actions,+-- but also for a large statically-known data as well. Instead of a top-level+-- definition, which once evaluated will slow down garbage collection+-- during all subsequent benchmarks,+--+-- > largeData :: String+-- > largeData = replicate 1000000 'a'+-- >+-- > main :: IO ()+-- > main = defaultMain+-- > [ bench "large" $ nf length largeData, ... ]+--+-- use+--+-- > import Control.DeepSeq (force)+-- > import Control.Exception (evaluate)+-- >+-- > main :: IO ()+-- > main = defaultMain+-- > [ env (evaluate (force (replicate 1000000 'a'))) $ \largeData ->+-- > bench "large" $ nf length largeData, ... ]+--+-- @Test.Tasty.Bench.@'env' is provided only for the sake of+-- compatibility with @Criterion.@'Criterion.env' and+-- @Gauge.@'Gauge.env', and involves 'unsafePerformIO'. Consider using+-- 'withResource' instead.+--+-- 'defaultMain' requires that the hierarchy of benchmarks and their names is+-- independent of underlying 'IO' actions. While executing 'IO' inside 'bench'+-- via 'nfIO' is fine, and reading test data from files via 'env' is also fine,+-- using 'env' to choose benchmarks or their names depending on 'IO' side effects+-- will throw a rather cryptic error message:+--+-- > Unhandled resource. Probably a bug in the runner you're using.+--+env :: NFData env => IO env -> (env -> Benchmark) -> Benchmark+env res = envWithCleanup res (const $ pure ())++-- | Similar to 'env', but includes an additional argument+-- to clean up created environment.+--+-- Provided only for the sake of compatibility with+-- @Criterion.@'Criterion.envWithCleanup' and+-- @Gauge.@'Gauge.envWithCleanup', and involves+-- 'unsafePerformIO'. Consider using 'withResource' instead.+--+envWithCleanup :: NFData env => IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark+envWithCleanup res fin f = withResource+ (res >>= evaluate . force)+ (void . fin)+ (f . unsafePerformIO)++-- | A path to write results in CSV format, populated by @--csv@.+--+-- This is an option of 'csvReporter' and can be set only globally.+-- Modifying it via 'adjustOption' or 'localOption' does not have any effect.+-- One can however pass it to 'tryIngredients' 'benchIngredients'. For example,+-- here is how to set a default CSV location:+--+-- @+-- import Data.Maybe+-- import System.Exit+-- import Test.Tasty.Bench+-- import Test.Tasty.Ingredients+-- import Test.Tasty.Options+-- import Test.Tasty.Runners+--+-- main :: IO ()+-- main = do+-- let benchmarks = bgroup \"All\" ...+-- opts <- parseOptions benchIngredients benchmarks+-- let opts' = changeOption (Just . fromMaybe (CsvPath "foo.csv")) opts+-- case tryIngredients benchIngredients opts' benchmarks of+-- Nothing -> exitFailure+-- Just mb -> mb >>= \\b -> if b then exitSuccess else exitFailure+-- @+--+newtype CsvPath = CsvPath FilePath+ deriving (Typeable)++instance IsOption (Maybe CsvPath) where+ defaultValue = Nothing+ parseValue = Just . Just . CsvPath+ optionName = pure "csv"+ optionHelp = pure "File to write results in CSV format"++-- | Run benchmarks and save results in CSV format.+-- It activates when @--csv@ @FILE@ command line option is specified.+--+csvReporter :: Ingredient+csvReporter = TestReporter [Option (Proxy :: Proxy (Maybe CsvPath))] $+ \opts tree -> do+ CsvPath path <- lookupOption opts+ let names = testsNames opts tree+ namesMap = IM.fromDistinctAscList $ zip [0..] names+ pure $ \smap -> do+ case findNonUniqueElement names of+ Nothing -> pure ()+ Just name -> do -- 'die' is not available before base-4.8+ hPutStrLn stderr $ "CSV report cannot proceed, because name '" ++ name ++ "' corresponds to two or more benchmarks. Please disambiguate them."+ exitFailure+ let augmented = IM.intersectionWith (,) namesMap smap+ bracket+ (do+ h <- openFile path WriteMode+ hSetBuffering h LineBuffering+ hPutStrLn h $ "Name,Mean (ps),2*Stdev (ps)" +++ (if hasGCStats then ",Allocated,Copied,Peak Memory" else "")+ pure h+ )+ hClose+ (`csvOutput` augmented)+ pure $ const $ isSuccessful smap++findNonUniqueElement :: Ord a => [a] -> Maybe a+findNonUniqueElement = go S.empty+ where+ go _ [] = Nothing+ go acc (x : xs)+ | x `S.member` acc = Just x+ | otherwise = go (S.insert x acc) xs++csvOutput :: Handle -> IntMap (TestName, TVar Status) -> IO ()+csvOutput h = traverse_ $ \(name, tv) -> do+ let csv = if hasGCStats then csvEstimateWithGC else csvEstimate+ r <- atomically $ readTVar tv >>= \s -> case s of Done r -> pure r; _ -> retry+ case safeRead (resultDescription r) of+ Nothing -> pure ()+ Just (WithLoHi est _ _) -> do+ msg <- formatMessage $ csv est+ hPutStrLn h (encodeCsv name ++ ',' : msg)++encodeCsv :: String -> String+encodeCsv xs+ | any (`elem` xs) ",\"\n\r"+ = '"' : go xs -- opening quote+ | otherwise = xs+ where+ go [] = '"' : [] -- closing quote+ go ('"' : ys) = '"' : '"' : go ys+ go (y : ys) = y : go ys++-- | A path to plot results in SVG format, populated by @--svg@.+--+-- This is an option of 'svgReporter' and can be set only globally.+-- Modifying it via 'adjustOption' or 'localOption' does not have any effect.+-- One can however pass it to 'tryIngredients' 'benchIngredients'.+--+newtype SvgPath = SvgPath FilePath+ deriving (Typeable)++instance IsOption (Maybe SvgPath) where+ defaultValue = Nothing+ parseValue = Just . Just . SvgPath+ optionName = pure "svg"+ optionHelp = pure "File to plot results in SVG format"++-- | Run benchmarks and plot results in SVG format.+-- It activates when @--svg@ @FILE@ command line option is specified.+--+svgReporter :: Ingredient+svgReporter = TestReporter [Option (Proxy :: Proxy (Maybe SvgPath))] $+ \opts tree -> do+ SvgPath path <- lookupOption opts+ let names = testsNames opts tree+ namesMap = IM.fromDistinctAscList $ zip [0..] names+ pure $ \smap -> do+ ref <- newIORef []+ svgCollect ref (IM.intersectionWith (,) namesMap smap)+ res <- readIORef ref+ writeFile path (svgRender (reverse res))+ pure $ const $ isSuccessful smap++isSuccessful :: StatusMap -> IO Bool+isSuccessful = go . IM.elems+ where+ go [] = pure True+ go (tv : tvs) = do+ b <- atomically $ readTVar tv >>= \s -> case s of Done r -> pure (resultSuccessful r); _ -> retry+ if b then go tvs else pure False++svgCollect :: IORef [(TestName, Estimate)] -> IntMap (TestName, TVar Status) -> IO ()+svgCollect ref = traverse_ $ \(name, tv) -> do+ r <- atomically $ readTVar tv >>= \s -> case s of Done r -> pure r; _ -> retry+ case safeRead (resultDescription r) of+ Nothing -> pure ()+ Just (WithLoHi est _ _) -> modifyIORef ref ((name, est) :)++svgRender :: [(TestName, Estimate)] -> String+svgRender [] = ""+svgRender pairs = header ++ concat (zipWith+ (\i (name, est) -> svgRenderItem i l xMax (dropAllPrefix name) est)+ [0..]+ pairs) ++ footer+ where+ dropAllPrefix+ | all (("All." `isPrefixOf`) . fst) pairs = drop 4+ | otherwise = id++ l = genericLength pairs+ findMaxX (Estimate m stdev) = measTime m + 2 * stdev+ xMax = word64ToDouble $ maximum $ minBound : map (findMaxX . snd) pairs+ header = printf "<svg xmlns=\"http://www.w3.org/2000/svg\" height=\"%i\" width=\"%f\" font-size=\"%i\" font-family=\"sans-serif\" stroke-width=\"2\">\n<g transform=\"translate(%f 0)\">\n" (svgItemOffset l - 15) svgCanvasWidth svgFontSize svgCanvasMargin+ footer = "</g>\n</svg>\n"++svgCanvasWidth :: Double+svgCanvasWidth = 960++svgCanvasMargin :: Double+svgCanvasMargin = 10++svgItemOffset :: Word64 -> Word64+svgItemOffset i = 22 + 55 * i++svgFontSize :: Word64+svgFontSize = 16++svgRenderItem :: Word64 -> Word64 -> Double -> TestName -> Estimate -> String+svgRenderItem i iMax xMax name est@(Estimate m stdev) =+ (if genericLength shortTextContent * glyphWidth < boxWidth then longText else shortText) ++ box+ where+ y = svgItemOffset i+ y' = y + (svgFontSize * 3) `quot` 8+ y1 = y' + whiskerMargin+ y2 = y' + boxHeight `quot` 2+ y3 = y' + boxHeight - whiskerMargin+ x1 = boxWidth - whiskerWidth+ x2 = boxWidth + whiskerWidth+ deg = (i * 360) `quot` iMax+ glyphWidth = word64ToDouble svgFontSize / 2++ scale w = word64ToDouble w * (svgCanvasWidth - 2 * svgCanvasMargin) / xMax+ boxWidth = scale (measTime m)+ whiskerWidth = scale (2 * stdev)+ boxHeight = 22+ whiskerMargin = 5++ box = printf boxTemplate+ (prettyEstimate est)+ y' boxHeight boxWidth deg deg+ deg+ x1 x2 y2 y2+ x1 x1 y1 y3+ x2 x2 y1 y3+ boxTemplate+ = "<g>\n<title>%s</title>\n"+ ++ "<rect y=\"%i\" rx=\"5\" height=\"%i\" width=\"%f\" fill=\"hsl(%i, 100%%, 80%%)\" stroke=\"hsl(%i, 100%%, 55%%)\" />\n"+ ++ "<g stroke=\"hsl(%i, 100%%, 40%%)\">"+ ++ "<line x1=\"%f\" x2=\"%f\" y1=\"%i\" y2=\"%i\" />\n"+ ++ "<line x1=\"%f\" x2=\"%f\" y1=\"%i\" y2=\"%i\" />\n"+ ++ "<line x1=\"%f\" x2=\"%f\" y1=\"%i\" y2=\"%i\" />\n"+ ++ "</g>\n</g>\n"++ longText = printf longTextTemplate+ deg+ y (encodeSvg name)+ y boxWidth (showPicos4 (measTime m))+ longTextTemplate+ = "<g fill=\"hsl(%i, 100%%, 40%%)\">\n"+ ++ "<text y=\"%i\">%s</text>\n"+ ++ "<text y=\"%i\" x=\"%f\" text-anchor=\"end\">%s</text>\n"+ ++ "</g>\n"++ shortTextContent = encodeSvg name ++ " " ++ showPicos4 (measTime m)+ shortText = printf shortTextTemplate deg y shortTextContent+ shortTextTemplate = "<text fill=\"hsl(%i, 100%%, 40%%)\" y=\"%i\">%s</text>\n"++encodeSvg :: String -> String+encodeSvg [] = []+encodeSvg ('<' : xs) = '&' : 'l' : 't' : ';' : encodeSvg xs+encodeSvg ('&' : xs) = '&' : 'a' : 'm' : 'p' : ';' : encodeSvg xs+encodeSvg (x : xs) = x : encodeSvg xs++-- | A path to read baseline results in CSV format, populated by @--baseline@.+--+-- This is an option of 'csvReporter' and can be set only globally.+-- Modifying it via 'adjustOption' or 'localOption' does not have any effect.+-- One can however pass it to 'tryIngredients' 'benchIngredients'.+--+newtype BaselinePath = BaselinePath FilePath+ deriving (Typeable)++instance IsOption (Maybe BaselinePath) where+ defaultValue = Nothing+ parseValue = Just . Just . BaselinePath+ optionName = pure "baseline"+ optionHelp = pure "File with baseline results in CSV format to compare against"++-- | Run benchmarks and report results+-- in a manner similar to 'consoleTestReporter'.+--+-- If @--baseline@ @FILE@ command line option is specified,+-- compare results against an earlier run and mark+-- too slow / too fast benchmarks as failed in accordance to+-- bounds specified by @--fail-if-slower@ @PERCENT@ and @--fail-if-faster@ @PERCENT@.+--+consoleBenchReporter :: Ingredient+consoleBenchReporter = modifyConsoleReporter [Option (Proxy :: Proxy (Maybe BaselinePath))] $ \opts -> do+ baseline <- case lookupOption opts of+ Nothing -> pure S.empty+ Just (BaselinePath path) -> S.fromList . joinQuotedFields . lines <$> (readFile path >>= evaluate . force)+ let pretty = if hasGCStats then prettyEstimateWithGC else prettyEstimate+ pure $ \name mDepR r -> case safeRead (resultDescription r) of+ Nothing -> r+ Just (WithLoHi est lowerBound upperBound) ->+ (if isAcceptable then id else forceFail)+ r { resultDescription = pretty est ++ bcompareMsg ++ formatSlowDown slowDown }+ where+ isAcceptable = isAcceptableVsBaseline && isAcceptableVsBcompare+ slowDown = compareVsBaseline baseline name est+ isAcceptableVsBaseline = slowDown >= lowerBound && slowDown <= upperBound+ (isAcceptableVsBcompare, bcompareMsg) = case mDepR of+ Nothing -> (True, "")+ Just (WithLoHi depR depLowerBound depUpperBound) -> case safeRead (resultDescription depR) of+ Nothing -> (True, "")+ Just (WithLoHi depEst _ _) -> let ratio = estTime est / estTime depEst in+ ( ratio >= depLowerBound && ratio <= depUpperBound+ , printf ", %.2fx" ratio+ )++-- | A well-formed CSV entry contains an even number of quotes: 0, 2 or more.+joinQuotedFields :: [String] -> [String]+joinQuotedFields [] = []+joinQuotedFields (x : xs)+ | areQuotesBalanced x = x : joinQuotedFields xs+ | otherwise = case span areQuotesBalanced xs of+ (_, []) -> [] -- malformed CSV+ (ys, z : zs) -> unlines (x : ys ++ [z]) : joinQuotedFields zs+ where+ areQuotesBalanced = even . length . filter (== '"')++estTime :: Estimate -> Double+estTime = word64ToDouble . measTime . estMean++compareVsBaseline :: S.Set String -> TestName -> Estimate -> Double+compareVsBaseline baseline name (Estimate m stdev) = case mOld of+ Nothing -> 1+ Just (oldTime, oldDoubleSigma)+ -- time and oldTime must be signed integers to use 'abs'+ | abs (time - oldTime) < max (2 * word64ToInt64 stdev) oldDoubleSigma -> 1+ | otherwise -> int64ToDouble time / int64ToDouble oldTime+ where+ time = word64ToInt64 $ measTime m++ mOld :: Maybe (Int64, Int64)+ mOld = do+ let prefix = encodeCsv name ++ ","+ (line, furtherLines) <- S.minView $ snd $ S.split prefix baseline++ case S.minView furtherLines of+ Nothing -> pure ()+ Just (nextLine, _) -> case stripPrefix prefix nextLine of+ Nothing -> pure ()+ -- If there are several lines matching prefix, skip them all.+ -- Should not normally happen, 'csvReporter' prohibits repeating test names.+ Just{} -> Nothing++ (timeCell, ',' : rest) <- span (/= ',') <$> stripPrefix prefix line+ let doubleSigmaCell = takeWhile (/= ',') rest+ (,) <$> safeRead timeCell <*> safeRead doubleSigmaCell++formatSlowDown :: Double -> String+formatSlowDown n = case m `compare` 0 of+ LT -> printf ", %2i%% faster than baseline" (-m)+ EQ -> ""+ GT -> printf ", %2i%% slower than baseline" m+ where+ m :: Int64+ m = truncate ((n - 1) * 100)++forceFail :: Result -> Result+forceFail r = r { resultOutcome = Failure TestFailed, resultShortDescription = "FAIL" }++data Unique a = None | Unique !a | NotUnique+ deriving (Functor)++appendUnique :: Unique a -> Unique a -> Unique a+appendUnique None a = a+appendUnique a None = a+appendUnique _ _ = NotUnique++#if MIN_VERSION_base(4,9,0)+instance Semigroup (Unique a) where+ (<>) = appendUnique+#endif++instance Monoid (Unique a) where+ mempty = None+#if MIN_VERSION_base(4,9,0)+ mappend = (<>)+#else+ mappend = appendUnique+#endif++modifyConsoleReporter+ :: [OptionDescription]+ -> (OptionSet -> IO (TestName -> Maybe (WithLoHi Result) -> Result -> Result))+ -> Ingredient+modifyConsoleReporter desc' iof = TestReporter (desc ++ desc') $ \opts tree ->+ let nameSeqs = IM.fromDistinctAscList $ zip [0..] $ testNameSeqs opts tree+ namesAndDeps = IM.fromDistinctAscList $ zip [0..] $ map (second isSingle)+ $ testNamesAndDeps nameSeqs opts tree+ modifySMap = (iof opts >>=) . flip postprocessResult+ . IM.intersectionWith (\(a, b) c -> (a, b, c)) namesAndDeps+ in (modifySMap >=>) <$> cb opts tree+ where+ (desc, cb) = case consoleTestReporter of+ TestReporter d c -> (d, c)+ _ -> error "modifyConsoleReporter: consoleTestReporter must be TestReporter"++ isSingle (Unique a) = Just a+ isSingle _ = Nothing++testNameSeqs :: OptionSet -> TestTree -> [Seq TestName]+testNameSeqs = foldTestTree trivialFold+ { foldSingle = const $ const . (:[]) . Seq.singleton+#if MIN_VERSION_tasty(1,4,0)+ , foldGroup = const $ map . (<|)+#else+ , foldGroup = map . (<|)+#endif+ }++testNamesAndDeps :: IntMap (Seq TestName) -> OptionSet -> TestTree -> [(TestName, Unique (WithLoHi IM.Key))]+testNamesAndDeps im = foldTestTree trivialFold+ { foldSingle = const $ const . (: []) . (, mempty)+#if MIN_VERSION_tasty(1,4,0)+ , foldGroup = const $ map . first . (++) . (++ ".")+ , foldAfter = const foldDeps+#else+ , foldGroup = map . first . (++) . (++ ".")+#if MIN_VERSION_tasty(1,2,0)+ , foldAfter = foldDeps+#endif+#endif+ }+#if MIN_VERSION_tasty(1,2,0)+ where+ foldDeps :: DependencyType -> Expr -> [(a, Unique (WithLoHi IM.Key))] -> [(a, Unique (WithLoHi IM.Key))]+ foldDeps AllSucceed (And (StringLit xs) p)+ | bcomparePrefix `isPrefixOf` xs+ , Just (lo :: Double, hi :: Double) <- safeRead $ drop (length bcomparePrefix) xs+ = map $ second $ mappend $ (\x -> WithLoHi x lo hi) <$> findMatchingKeys im p+ foldDeps _ _ = id++findMatchingKeys :: IntMap (Seq TestName) -> Expr -> Unique IM.Key+findMatchingKeys im pattern =+ foldMap (\(k, v) -> if withFields v pat == Right True then Unique k else mempty) $ IM.assocs im+ where+ pat = eval pattern >>= asB+#endif++postprocessResult+ :: (TestName -> Maybe (WithLoHi Result) -> Result -> Result)+ -> IntMap (TestName, Maybe (WithLoHi IM.Key), TVar Status)+ -> IO StatusMap+postprocessResult f src = do+ paired <- forM src $ \(name, mDepId, tv) -> (name, mDepId, tv,) <$> newTVarIO NotStarted+ let doUpdate = atomically $ do+ (Any anyUpdated, All allDone) <-+ getApp $ flip foldMap paired $ \(name, mDepId, newTV, oldTV) -> Ap $ do+ old <- readTVar oldTV+ case old of+ Done{} -> pure (Any False, All True)+ _ -> do+ new <- readTVar newTV+ case new of+ Done res -> do++ depRes <- case mDepId of+ Nothing -> pure Nothing+ Just (WithLoHi depId lo hi) -> case IM.lookup depId src of+ Nothing -> pure Nothing+ Just (_, _, depTV) -> do+ depStatus <- readTVar depTV+ case depStatus of+ Done dep -> pure $ Just (WithLoHi dep lo hi)+ _ -> pure Nothing++ writeTVar oldTV (Done (f name depRes res))+ pure (Any True, All True)+ -- ignoring Progress nodes, we do not report any+ -- it would be helpful to have instance Eq Progress+ _ -> pure (Any False, All False)+ if anyUpdated || allDone then pure allDone else retry+ adNauseam = doUpdate >>= (`unless` adNauseam)+ _ <- forkIO adNauseam+ pure $ fmap (\(_, _, _, a) -> a) paired++int64ToDouble :: Int64 -> Double+int64ToDouble = fromIntegral++word64ToInt64 :: Word64 -> Int64+word64ToInt64 = fromIntegral++#endif++word64ToDouble :: Word64 -> Double+word64ToDouble = fromIntegral++#if !MIN_VERSION_base(4,10,0) && MIN_VERSION_base(4,6,0)+int64ToWord64 :: Int64 -> Word64+int64ToWord64 = fromIntegral+#endif
cbits/utils.c view
@@ -66,6 +66,30 @@ return ret; } +ssize_t _hs_text_lines_length_utf16_as_utf8(const uint16_t *arr, size_t off, size_t len)+{+ const uint16_t *src = arr + off;+ const uint16_t *srcend = src + len;+ ssize_t ret = 0;++ while (src < srcend){+ uint16_t codeUnit = *src++;++ if (codeUnit < 0x80){+ ret += 1;+ } else if (codeUnit < 0x800){+ ret += 2;+ } else if (codeUnit >= 0xd800 && codeUnit <= 0xdbff){+ src++;+ ret += 4;+ } else {+ ret += 3;+ }+ }++ return ret;+}+ ssize_t _hs_text_lines_take_utf8_as_utf16(const uint8_t *arr, size_t off, size_t len, size_t cnt) { const uint8_t *src = arr + off;@@ -109,6 +133,32 @@ if(cnt < 2) return -1; cnt-=2; src+=3;+ }+ }++ return src - arr - off;+}++ssize_t _hs_text_lines_take_utf16_as_utf8(const uint16_t *arr, size_t off, size_t len, size_t cnt)+{+ const uint16_t *src = arr + off;+ const uint16_t *srcend = src + len;++ while (src < srcend && cnt > 0){+ uint16_t codeUnit = *src++;++ if (codeUnit < 0x80){+ cnt -= 1;+ } else if (codeUnit < 0x800){+ if (cnt < 2) return -1;+ cnt -= 2;+ } else if (codeUnit >= 0xd800 && codeUnit <= 0xdbff){+ src++;+ if (cnt < 4) return -1;+ cnt -= 4;+ } else {+ if (cnt < 3) return -1;+ cnt -= 3; } }
changelog.md view
@@ -1,3 +1,11 @@+# 0.3++* Move `Data.Text.Utf16.Rope.Mixed` module to `Data.Text.Mixed.Rope`. `Data.Text.Utf16.Rope.Mixed` re-exports `Data.Text.Mixed.Rope` for legacy clients.+* Add `Data.Text.Utf8.Lines` and `Data.Text.Utf8.Rope` modules for ropes indexed by UTF-8 code units.+* Add UTF-8 indexing functionality to `Data.Text.Mixed.Rope`.+* The metrics stored internally in the rope nodes has changed, which should improve performance by making some re-measuring redundant. As a consequence, the time complexity of `Data.Text.Rope.lengthAsPosition` is now linear in the length of the last line.+* Add `getLine` functions to extract lines by 0-based index.+ # 0.2 * Share `TextLines` between `Char` and UTF-16 modules.
src/Data/Text/Lines.hs view
@@ -9,6 +9,7 @@ , toText , null -- * Lines+ , getLine , lines , lengthInLines , splitAtLine
src/Data/Text/Lines/Internal.hs view
@@ -13,8 +13,10 @@ , fromText , null -- * Lines+ , getLine , lines , lengthInLines+ , newlines , splitAtLine -- * Code points , length@@ -194,6 +196,23 @@ Nothing -> 0 Just (_, ch) -> intToWord $ U.length nls + (if ch == '\n' then 0 else 1) +-- | The number of newline characters, O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> newlines ""+-- 0+-- >>> newlines "foo"+-- 0+-- >>> newlines "foo\n"+-- 1+-- >>> newlines "foo\n\n"+-- 2+-- >>> newlines "foo\nbar"+-- 1+--+newlines :: TextLines -> Word+newlines (TextLines _ nls) = intToWord $ U.length nls+ -- | Split into lines by @\\n@, similar to @Data.Text.@'Data.Text.lines'. -- Each line is produced in O(1). --@@ -224,6 +243,26 @@ -- splitAtLine :: HasCallStack => Word -> TextLines -> (TextLines, TextLines) splitAtLine k = splitAtPosition (Position k 0)++-- | Get line with given 0-based index, O(1).+-- The result does not contain @\\n@ characters..+-- Returns 'mempty' if the line index is out of bounds.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\l -> getLine l "fя𐀀\n☺bar\n\n") [0..3]+-- ["fя𐀀","☺bar","",""]+--+-- @since 0.3+getLine :: Word -> TextLines -> TextLines+getLine line (TextLines t@(Text arr off len) nls)+ | intToWord (U.length nls) < line = mempty+ | otherwise =+ let lineIdx = wordToInt line+ in (`TextLines` mempty) $ case (nls U.!? (lineIdx - 1), nls U.!? lineIdx) of+ (Nothing, Nothing) -> t+ (Nothing, Just endNl) -> Text arr off (endNl - off) -- branch triggered by `getLine 0 "a\n"`+ (Just startNl, Nothing) -> Text arr (startNl + 1) (len + off - startNl - 1)+ (Just startNl, Just endNl) -> Text arr (startNl + 1) (endNl - startNl - 1) ------------------------------------------------------------------------------- -- Unicode code points
+ src/Data/Text/Mixed/Rope.hs view
@@ -0,0 +1,589 @@+-- |+-- Copyright: (c) 2021-2022 Andrew Lelechenko+-- Licence: BSD3+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- @since 0.3++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}++#ifdef DEBUG+#define DEFRAGMENTATION_THRESHOLD 4+#else+#define DEFRAGMENTATION_THRESHOLD 4096+#endif++module Data.Text.Mixed.Rope+ ( Rope+ , fromText+ , fromTextLines+ , toText+ , toTextLines+ , null+ -- * Lines+ , lines+ , lengthInLines+ , splitAtLine+ , getLine+ -- * Code points+ , charLength+ , charSplitAt+ , charLengthAsPosition+ , charSplitAtPosition+ -- * UTF-16 code units+ , utf16Length+ , utf16SplitAt+ , utf16LengthAsPosition+ , utf16SplitAtPosition+ -- * UTF-8 code units+ , utf8Length+ , utf8SplitAt+ , utf8LengthAsPosition+ , utf8SplitAtPosition+ ) where++import Prelude ((-), (+), seq)+import Control.DeepSeq (NFData, rnf)+import Data.Bool (Bool(..), otherwise)+import Data.Char (Char)+import Data.Eq (Eq, (==))+import Data.Function ((.), ($), on)+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord, compare, (<), (<=))+import Data.Semigroup (Semigroup(..))+import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TextLazy+import qualified Data.Text.Lazy.Builder as Builder+import Data.Text.Lines.Internal (TextLines)+import qualified Data.Text.Lines.Internal as TL (null, fromText, toText, lines, splitAtLine, newlines)+import qualified Data.Text.Lines as Char+import qualified Data.Text.Utf8.Lines as Utf8+import qualified Data.Text.Utf16.Lines as Utf16+import Data.Word (Word)+import Text.Show (Show)++#ifdef DEBUG+import Prelude (error)+import GHC.Stack (HasCallStack)+#else+#define HasCallStack ()+import Text.Show (show)+#endif++-- | Rope of 'Text' chunks with logarithmic concatenation. This rope offers+-- three interfaces: one based on code points, one based on UTF-16 code units,+-- and one based on UTF-8 code units. This comes with a price of more+-- bookkeeping and is less performant than "Data.Text.Rope",+-- "Data.Text.Utf8.Rope", or "Data.Text.Utf16.Rope".+data Rope+ = Empty+ | Node+ { _ropeLeft :: !Rope+ , _ropeMiddle :: !TextLines+ , _ropeRight :: !Rope+ , _ropeMetrics :: {-# UNPACK #-} !Metrics+ }++data Metrics = Metrics+ { _metricsNewlines :: !Word+ , _metricsCharLen :: !Word+ , _metricsUtf8Len :: !Word+ , _metricsUtf16Len :: !Word+ }++instance NFData Rope where+ rnf Empty = ()+ -- No need to deepseq strict fields, for which WHNF = NF+ rnf (Node l _ r _) = rnf l `seq` rnf r++instance Eq Rope where+ (==) = (==) `on` toLazyText++instance Ord Rope where+ compare = compare `on` toLazyText++instance Semigroup Metrics where+ Metrics nls1 c1 u1 u1' <> Metrics nls2 c2 u2 u2' =+ Metrics (nls1 + nls2) (c1 + c2) (u1 + u2) (u1' + u2')+ {-# INLINE (<>) #-}++instance Monoid Metrics where+ mempty = Metrics 0 0 0 0+ mappend = (<>)++subMetrics :: Metrics -> Metrics -> Metrics+subMetrics (Metrics nls1 c1 u1 u1') (Metrics nls2 c2 u2 u2') =+ Metrics (nls1 - nls2) (c1 - c2) (u1 - u2) (u1' - u2')++metrics :: Rope -> Metrics+metrics = \case+ Empty -> mempty+ Node _ _ _ m -> m++linesMetrics :: Char.TextLines -> Metrics+linesMetrics tl = Metrics+ { _metricsNewlines = TL.newlines tl+ , _metricsCharLen = charLen+ , _metricsUtf8Len = utf8Len+ , _metricsUtf16Len = if charLen == utf8Len then charLen else Utf16.length tl+ }+ where+ charLen = Char.length tl+ utf8Len = Utf8.length tl+++#ifdef DEBUG+deriving instance Show Metrics+deriving instance Show Rope+#else+instance Show Rope where+ show = show . toLazyText+#endif++instance IsString Rope where+ fromString = fromTextLines . fromString++-- | Check whether a rope is empty, O(1).+null :: Rope -> Bool+null = \case+ Empty -> True+ Node{} -> False++-- | Length in code points, similar to @Data.Text.@'Data.Text.length', O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> charLength "fя𐀀"+-- 3+--+charLength :: Rope -> Word+charLength = _metricsCharLen . metrics++-- | Length in UTF-8 code units aka bytes, O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> utf8Length "fя𐀀"+-- 4+--+utf8Length :: Rope -> Word+utf8Length = _metricsUtf8Len . metrics++-- | Length in UTF-16 code units, O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> utf16Length "fя𐀀"+-- 4+--+utf16Length :: Rope -> Word+utf16Length = _metricsUtf16Len . metrics++-- | The number of newline characters, O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> newlines ""+-- 0+-- >>> newlines "foo"+-- 0+-- >>> newlines "foo\n"+-- 1+-- >>> newlines "foo\n\n"+-- 2+-- >>> newlines "foo\nbar"+-- 1+--+newlines :: Rope -> Word+newlines = _metricsNewlines . metrics++-- | Measure text length as an amount of lines and columns.+-- Time is linear in the length of the last line.+--+-- >>> :set -XOverloadedStrings+-- >>> charLengthAsPosition "f𐀀"+-- Position {posLine = 0, posColumn = 2}+-- >>> charLengthAsPosition "f\n𐀀"+-- Position {posLine = 1, posColumn = 1}+-- >>> charLengthAsPosition "f\n𐀀\n"+-- Position {posLine = 2, posColumn = 0}+--+charLengthAsPosition :: Rope -> Char.Position+charLengthAsPosition rp =+ Char.Position nls (charLength line)+ where+ nls = newlines rp+ (_, line) = splitAtLine nls rp++-- | Measure text length as an amount of lines and columns.+-- Time is linear in the length of the last line.+--+utf8LengthAsPosition :: Rope -> Utf8.Position+utf8LengthAsPosition rp =+ Utf8.Position nls (utf8Length line)+ where+ nls = newlines rp+ (_, line) = splitAtLine nls rp++-- | Measure text length as an amount of lines and columns.+-- Time is linear in the length of the last line.+--+-- >>> :set -XOverloadedStrings+-- >>> utf16LengthAsPosition "f𐀀"+-- Position {posLine = 0, posColumn = 3}+-- >>> utf16LengthAsPosition "f\n𐀀"+-- Position {posLine = 1, posColumn = 2}+-- >>> utf16LengthAsPosition "f\n𐀀\n"+-- Position {posLine = 2, posColumn = 0}+--+utf16LengthAsPosition :: Rope -> Utf16.Position+utf16LengthAsPosition rp =+ Utf16.Position nls (utf16Length line)+ where+ nls = newlines rp+ (_, line) = splitAtLine nls rp++instance Semigroup Rope where+ Empty <> t = t+ t <> Empty = t+ Node l1 c1 r1 m1 <> Node l2 c2 r2 m2 = defragment+ l1+ c1+ (Node (r1 <> l2) c2 r2 (metrics r1 <> m2))+ (m1 <> m2)++instance Monoid Rope where+ mempty = Empty+ mappend = (<>)++defragment :: HasCallStack => Rope -> TextLines -> Rope -> Metrics -> Rope+defragment !l !c !r !m+#ifdef DEBUG+ | TL.null c = error "Data.Text.Lines: violated internal invariant"+#endif+ | _metricsUtf16Len m < DEFRAGMENTATION_THRESHOLD+ = Node Empty (toTextLines rp) Empty m+ | otherwise+ = rp+ where+ rp = Node l c r m++-- | Create from 'TextLines', linear time.+fromTextLines :: TextLines -> Rope+fromTextLines tl+ | TL.null tl = Empty+ | otherwise = Node Empty tl Empty (linesMetrics tl)++-- | Create a 'Node', defragmenting it if necessary. The 'Metrics' argument is+-- the computed metrics of the 'TL.TextLines' argument.+node :: HasCallStack => Rope -> TextLines -> Metrics -> Rope -> Rope+node l c cm r = defragment l c r (metrics l <> cm <> metrics r)++-- | Append a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+snoc :: Rope -> TextLines -> Metrics -> Rope+snoc tr tl tlm+ | TL.null tl = tr+ | otherwise = node tr tl tlm Empty++-- | Prepend a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+cons :: TextLines -> Metrics -> Rope -> Rope+cons tl tlm tr+ | TL.null tl = tr+ | otherwise = node Empty tl tlm tr++-- | Create from 'Text', linear time.+fromText :: Text -> Rope+fromText = fromTextLines . TL.fromText++foldMapRope :: Monoid a => (TextLines -> a) -> Rope -> a+foldMapRope f = go+ where+ go = \case+ Empty -> mempty+ Node l c r _ -> go l `mappend` f c `mappend` go r++data Lines = Lines ![Text] !Bool++instance Semigroup Lines where+ Lines [] _ <> ls = ls+ ls <> Lines [] _ = ls+ Lines xs x <> Lines ys y = Lines (if x then xs <> ys else go xs ys) y+ where+ go [] vs = vs+ go [u] (v : vs) = (u <> v) : vs+ go (u : us) vs = u : go us vs++instance Monoid Lines where+ mempty = Lines [] False+ mappend = (<>)++-- | Split into lines by @\\n@, similar to @Data.Text.@'Data.Text.lines'.+-- Each line is produced in O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> lines ""+-- []+-- >>> lines "foo"+-- ["foo"]+-- >>> lines "foo\n"+-- ["foo"]+-- >>> lines "foo\n\n"+-- ["foo",""]+-- >>> lines "foo\nbar"+-- ["foo","bar"]+--+lines :: Rope -> [Text]+lines = (\(Lines ls _) -> ls) . foldMapRope+ -- This assumes that there are no empty chunks:+ (\tl -> Lines (TL.lines tl) (T.last (TL.toText tl) == '\n'))++lastChar :: Rope -> Maybe Char+lastChar = \case+ Empty -> Nothing+ -- This assumes that there are no empty chunks:+ Node _ c Empty _ -> Just $ T.last $ TL.toText c+ Node _ _ r _ -> lastChar r++-- | Equivalent to 'Data.List.length' . 'lines', but in logarithmic time.+--+-- >>> :set -XOverloadedStrings+-- >>> lengthInLines ""+-- 0+-- >>> lengthInLines "foo"+-- 1+-- >>> lengthInLines "foo\n"+-- 1+-- >>> lengthInLines "foo\n\n"+-- 2+-- >>> lengthInLines "foo\nbar"+-- 2+--+-- If you do not care about ignoring the last newline character,+-- you can use 'Char.posLine' . 'charLengthAsPosition' instead, which works in O(1).+--+lengthInLines :: Rope -> Word+lengthInLines rp = case lastChar rp of+ Nothing -> 0+ Just ch -> Char.posLine (charLengthAsPosition rp) + (if ch == '\n' then 0 else 1)++-- | Glue chunks into 'TextLines', linear time.+toTextLines :: Rope -> TextLines+toTextLines = mconcat . foldMapRope (:[])++toLazyText :: Rope -> TextLazy.Text+toLazyText = foldMapRope (TextLazy.fromStrict . TL.toText)++-- | Glue chunks into 'Text', linear time.+toText :: Rope -> Text+toText = TextLazy.toStrict . Builder.toLazyText . foldMapRope (Builder.fromText . TL.toText)++-- | Split at given code point, similar to @Data.Text.@'Data.Text.splitAt'.+-- Takes linear time.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\c -> charSplitAt c "fя𐀀") [0..4]+-- [("","fя𐀀"),("f","я𐀀"),("fя","𐀀"),("fя𐀀",""),("fя𐀀","")]+--+charSplitAt :: HasCallStack => Word -> Rope -> (Rope, Rope)+charSplitAt !len = \case+ Empty -> (Empty, Empty)+ Node l c r m+ | len <= ll -> case charSplitAt len l of+ (before, after) -> (before, node after c cm r)+ | len <= llc -> do+ let i = len - ll+ case Char.splitAt i c of+ (before, after) -> do+ let utf8Len = Utf8.length before+ let beforeMetrics = Metrics+ { _metricsNewlines = TL.newlines before+ , _metricsCharLen = i+ , _metricsUtf8Len = utf8Len+ , _metricsUtf16Len = if i == utf8Len then i else Utf16.length before+ }+ let afterMetrics = subMetrics cm beforeMetrics+ (snoc l before beforeMetrics, cons after afterMetrics r)+ | otherwise -> case charSplitAt (len - llc) r of+ (before, after) -> (node l c cm before, after)+ where+ ll = charLength l+ llc = ll + _metricsCharLen cm+ cm = subMetrics m (metrics l <> metrics r)++-- | Split at given UTF-8 code unit aka byte.+-- If requested number of code units splits a code point in half, return 'Nothing'.+-- Takes linear time.+--+utf8SplitAt :: HasCallStack => Word -> Rope -> Maybe (Rope, Rope)+utf8SplitAt !len = \case+ Empty -> Just (Empty, Empty)+ Node l c r m+ | len <= ll -> case utf8SplitAt len l of+ Nothing -> Nothing+ Just (before, after) -> Just (before, node after c cm r)+ | len <= llc -> do+ let i = len - ll+ case Utf8.splitAt (len - ll) c of+ Nothing -> Nothing+ Just (before, after) -> do+ let charLen = Char.length before+ let beforeMetrics = Metrics+ { _metricsNewlines = TL.newlines before+ , _metricsCharLen = charLen+ , _metricsUtf8Len = i+ , _metricsUtf16Len = if i == charLen then i else Utf16.length before+ }+ let afterMetrics = subMetrics cm beforeMetrics+ Just (snoc l before beforeMetrics, cons after afterMetrics r)+ | otherwise -> case utf8SplitAt (len - llc) r of+ Nothing -> Nothing+ Just (before, after) -> Just (node l c cm before, after)+ where+ ll = utf8Length l+ llc = ll + _metricsUtf8Len cm+ cm = subMetrics m (metrics l <> metrics r)++-- | Split at given UTF-16 code unit.+-- If requested number of code units splits a code point in half, return 'Nothing'.+-- Takes linear time.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\c -> utf16SplitAt c "fя𐀀") [0..4]+-- [Just ("","fя𐀀"),Just ("f","я𐀀"),Just ("fя","𐀀"),Nothing,Just ("fя𐀀","")]+--+utf16SplitAt :: HasCallStack => Word -> Rope -> Maybe (Rope, Rope)+utf16SplitAt !len = \case+ Empty -> Just (Empty, Empty)+ Node l c r m+ | len <= ll -> case utf16SplitAt len l of+ Nothing -> Nothing+ Just (before, after) -> Just (before, node after c cm r)+ | len <= llc -> do+ let i = len - ll+ case Utf16.splitAt (len - ll) c of+ Nothing -> Nothing+ Just (before, after) -> do+ let beforeMetrics = Metrics+ { _metricsNewlines = TL.newlines before+ , _metricsCharLen = Char.length before+ , _metricsUtf8Len = Utf8.length before+ , _metricsUtf16Len = i+ }+ let afterMetrics = subMetrics cm beforeMetrics+ Just (snoc l before beforeMetrics, cons after afterMetrics r)+ | otherwise -> case utf16SplitAt (len - llc) r of+ Nothing -> Nothing+ Just (before, after) -> Just (node l c cm before, after)+ where+ ll = utf16Length l+ llc = ll + _metricsUtf16Len cm+ cm = subMetrics m (metrics l <> metrics r)++-- | Split at given line, logarithmic time.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\l -> splitAtLine l "foo\nbar") [0..3]+-- [("","foo\nbar"),("foo\n","bar"),("foo\nbar",""),("foo\nbar","")]+--+splitAtLine :: HasCallStack => Word -> Rope -> (Rope, Rope)+splitAtLine !len = \case+ Empty -> (Empty, Empty)+ Node l c r m+ | len <= ll -> case splitAtLine len l of+ (before, after) -> (before, node after c cm r)+ | len <= llc -> do+ let i = len - ll+ case TL.splitAtLine i c of+ (before, after) -> do+ let beforeMetrics = linesMetrics before+ let afterMetrics = subMetrics cm beforeMetrics+ (snoc l before beforeMetrics, cons after afterMetrics r)+ | otherwise -> case splitAtLine (len - llc) r of+ (before, after) -> (node l c cm before, after)+ where+ -- posLine is the same both in Char.lengthAsPosition and Utf16.lengthAsPosition+ ll = newlines l+ llc = ll + _metricsNewlines cm+ cm = subMetrics m (metrics l <> metrics r)++-- | Combination of 'splitAtLine' and subsequent 'charSplitAt'.+-- Time is linear in 'Char.posColumn' and logarithmic in 'Char.posLine'.+--+-- >>> :set -XOverloadedStrings+-- >>> charSplitAtPosition (Position 1 0) "f\n𐀀я"+-- ("f\n","𐀀я")+-- >>> charSplitAtPosition (Position 1 1) "f\n𐀀я"+-- ("f\n𐀀","я")+-- >>> charSplitAtPosition (Position 1 2) "f\n𐀀я"+-- ("f\n𐀀я","")+-- >>> charSplitAtPosition (Position 0 2) "f\n𐀀я"+-- ("f\n","𐀀я")+-- >>> charSplitAtPosition (Position 0 3) "f\n𐀀я"+-- ("f\n𐀀","я")+-- >>> charSplitAtPosition (Position 0 4) "f\n𐀀я"+-- ("f\n𐀀я","")+--+charSplitAtPosition :: HasCallStack => Char.Position -> Rope -> (Rope, Rope)+charSplitAtPosition (Char.Position l c) rp = (beforeLine <> beforeColumn, afterColumn)+ where+ (beforeLine, afterLine) = splitAtLine l rp+ (beforeColumn, afterColumn) = charSplitAt c afterLine++-- | Combination of 'splitAtLine' and subsequent 'utf8SplitAt'.+-- Time is linear in 'Utf8.posColumn' and logarithmic in 'Utf8.posLine'.+--+utf8SplitAtPosition :: HasCallStack => Utf8.Position -> Rope -> Maybe (Rope, Rope)+utf8SplitAtPosition (Utf8.Position l c) rp = do+ let (beforeLine, afterLine) = splitAtLine l rp+ (beforeColumn, afterColumn) <- utf8SplitAt c afterLine+ Just (beforeLine <> beforeColumn, afterColumn)++-- | Combination of 'splitAtLine' and subsequent 'utf16SplitAt'.+-- Time is linear in 'Utf16.posColumn' and logarithmic in 'Utf16.posLine'.+--+-- >>> :set -XOverloadedStrings+-- >>> utf16SplitAtPosition (Position 1 0) "f\n𐀀я"+-- Just ("f\n","𐀀я")+-- >>> utf16SplitAtPosition (Position 1 1) "f\n𐀀я"+-- Nothing+-- >>> utf16SplitAtPosition (Position 1 2) "f\n𐀀я"+-- Just ("f\n𐀀","я")+-- >>> utf16SplitAtPosition (Position 0 2) "f\n𐀀я"+-- Just ("f\n","𐀀я")+-- >>> utf16SplitAtPosition (Position 0 3) "f\n𐀀я"+-- Nothing+-- >>> utf16SplitAtPosition (Position 0 4) "f\n𐀀я"+-- Just ("f\n𐀀","я")+--+utf16SplitAtPosition :: HasCallStack => Utf16.Position -> Rope -> Maybe (Rope, Rope)+utf16SplitAtPosition (Utf16.Position l c) rp = do+ let (beforeLine, afterLine) = splitAtLine l rp+ (beforeColumn, afterColumn) <- utf16SplitAt c afterLine+ Just (beforeLine <> beforeColumn, afterColumn)++-- | Get a line by its 0-based index.+-- Returns 'mempty' if the index is out of bounds.+-- The result doesn't contain @\\n@ characters.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\l -> getLine l "foo\nbar\n😊😊\n\n") [0..3]+-- ["foo","bar","😊😊",""]+--+-- @since 0.3+getLine :: Word -> Rope -> Rope+getLine lineIdx rp =+ case charSplitAt (charLength firstLine - 1) firstLine of+ (firstLineInit, firstLineLast)+ | isNewline firstLineLast -> firstLineInit+ _ -> firstLine+ where+ (_, afterIndex) = splitAtLine lineIdx rp+ (firstLine, _ ) = splitAtLine 1 afterIndex++isNewline :: Rope -> Bool+isNewline = (== T.singleton '\n') . toText
src/Data/Text/Rope.hs view
@@ -28,6 +28,7 @@ , lines , lengthInLines , splitAtLine+ , getLine -- * Code points , length , splitAt@@ -44,7 +45,7 @@ import Data.Function ((.), ($), on) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..))-import Data.Ord (Ord, compare, (<), (<=), Ordering(..))+import Data.Ord (Ord, compare, (<), (<=)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) import Data.Text (Text)@@ -53,6 +54,7 @@ import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lines (Position(..)) import qualified Data.Text.Lines as TL+import qualified Data.Text.Lines.Internal as TL (newlines) import Data.Word (Word) import Text.Show (Show) @@ -67,21 +69,25 @@ -- | Rope of 'Text' chunks with logarithmic concatenation. -- This rope offers an interface, based on code points. -- Use "Data.Text.Utf16.Rope", if you need UTF-16 code units,--- or "Data.Text.Utf16.Rope.Mixed", if you need both interfaces.+-- or "Data.Text.Mixed.Rope", if you need both interfaces. data Rope = Empty | Node- { _ropeLeft :: !Rope- , _ropeMiddle :: !TL.TextLines- , _ropeRight :: !Rope- , _ropeCharLen :: !Word- , _ropeCharLenAsPos :: !Position+ { _ropeLeft :: !Rope+ , _ropeMiddle :: !TL.TextLines+ , _ropeRight :: !Rope+ , _ropeMetrics :: {-# UNPACK #-} !Metrics } +data Metrics = Metrics+ { _metricsNewlines :: !Word+ , _metricsCharLen :: !Word+ }+ instance NFData Rope where rnf Empty = () -- No need to deepseq strict fields, for which WHNF = NF- rnf (Node l _ r _ _) = rnf l `seq` rnf r+ rnf (Node l _ r _) = rnf l `seq` rnf r instance Eq Rope where (==) = (==) `on` toLazyText@@ -89,7 +95,32 @@ instance Ord Rope where compare = compare `on` toLazyText +instance Semigroup Metrics where+ Metrics nls1 c1 <> Metrics nls2 c2 =+ Metrics (nls1 + nls2) (c1 + c2)+ {-# INLINE (<>) #-}++instance Monoid Metrics where+ mempty = Metrics 0 0+ mappend = (<>)++subMetrics :: Metrics -> Metrics -> Metrics+subMetrics (Metrics nls1 c1) (Metrics nls2 c2) =+ Metrics (nls1 - nls2) (c1 - c2)++metrics :: Rope -> Metrics+metrics = \case+ Empty -> mempty+ Node _ _ _ m -> m++linesMetrics :: TL.TextLines -> Metrics+linesMetrics tl = Metrics+ { _metricsNewlines = TL.newlines tl+ , _metricsCharLen = TL.length tl+ }+ #ifdef DEBUG+deriving instance Show Metrics deriving instance Show Rope #else instance Show Rope where@@ -114,13 +145,29 @@ -- 4 -- length :: Rope -> Word-length = \case- Empty -> 0- Node _ _ _ w _ -> w+length = _metricsCharLen . metrics --- | Measure text length as an amount of lines and columns, O(1).+-- | The number of newline characters, O(1). -- -- >>> :set -XOverloadedStrings+-- >>> newlines ""+-- 0+-- >>> newlines "foo"+-- 0+-- >>> newlines "foo\n"+-- 1+-- >>> newlines "foo\n\n"+-- 2+-- >>> newlines "foo\nbar"+-- 1+--+newlines :: Rope -> Word+newlines = _metricsNewlines . metrics++-- | Measure text length as an amount of lines and columns.+-- Time is linear in the length of the last line.+--+-- >>> :set -XOverloadedStrings -- >>> lengthAsPosition "f𐀀" -- Position {posLine = 0, posColumn = 2} -- >>> lengthAsPosition "f\n𐀀"@@ -129,57 +176,59 @@ -- Position {posLine = 2, posColumn = 0} -- lengthAsPosition :: Rope -> Position-lengthAsPosition = \case- Empty -> mempty- Node _ _ _ _ p -> p+lengthAsPosition rp =+ Position nls (length line)+ where+ nls = newlines rp+ (_, line) = splitAtLine nls rp instance Semigroup Rope where Empty <> t = t t <> Empty = t- Node l1 c1 r1 u1 p1 <> Node l2 c2 r2 u2 p2 = defragment+ Node l1 c1 r1 m1 <> Node l2 c2 r2 m2 = defragment l1 c1- (Node (r1 <> l2) c2 r2 (length r1 + u2) (lengthAsPosition r1 <> p2))- (u1 + u2)- (p1 <> p2)+ (Node (r1 <> l2) c2 r2 (metrics r1 <> m2))+ (m1 <> m2) instance Monoid Rope where mempty = Empty mappend = (<>) -defragment :: HasCallStack => Rope -> TL.TextLines -> Rope -> Word -> Position -> Rope-defragment !l !c !r !u !p+defragment :: HasCallStack => Rope -> TL.TextLines -> Rope -> Metrics -> Rope+defragment !l !c !r !m #ifdef DEBUG | TL.null c = error "Data.Text.Lines: violated internal invariant" #endif- | u < DEFRAGMENTATION_THRESHOLD- = Node Empty (toTextLines rp) Empty u p+ | _metricsCharLen m < DEFRAGMENTATION_THRESHOLD+ = Node Empty (toTextLines rp) Empty m | otherwise = rp where- rp = Node l c r u p+ rp = Node l c r m -- | Create from 'TL.TextLines', linear time. fromTextLines :: TL.TextLines -> Rope fromTextLines tl | TL.null tl = Empty- | otherwise = Node Empty tl Empty (TL.length tl) (TL.lengthAsPosition tl)+ | otherwise = Node Empty tl Empty (linesMetrics tl) -node :: HasCallStack => Rope -> TL.TextLines -> Rope -> Rope-node l c r = defragment l c r totalLength totalLengthAsPosition- where- totalLength = length l + TL.length c + length r- totalLengthAsPosition = lengthAsPosition l <> TL.lengthAsPosition c <> lengthAsPosition r+-- | Create a 'Node', defragmenting it if necessary. The 'Metrics' argument is+-- the computed metrics of the 'TL.TextLines' argument.+node :: HasCallStack => Rope -> TL.TextLines -> Metrics -> Rope -> Rope+node l c cm r = defragment l c r (metrics l <> cm <> metrics r) -(|>) :: Rope -> TL.TextLines -> Rope-tr |> tl+-- | Append a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+snoc :: Rope -> TL.TextLines -> Metrics -> Rope+snoc tr tl tlm | TL.null tl = tr- | otherwise = node tr tl Empty+ | otherwise = node tr tl tlm Empty -(<|) :: TL.TextLines -> Rope -> Rope-tl <| tr+-- | Prepend a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+cons :: TL.TextLines -> Metrics -> Rope -> Rope+cons tl tlm tr | TL.null tl = tr- | otherwise = node Empty tl tr+ | otherwise = node Empty tl tlm tr -- | Create from 'Text', linear time. fromText :: Text -> Rope@@ -190,7 +239,7 @@ where go = \case Empty -> mempty- Node l c r _ _ -> go l `mappend` f c `mappend` go r+ Node l c r _ -> go l `mappend` f c `mappend` go r data Lines = Lines ![Text] !Bool @@ -231,8 +280,8 @@ lastChar = \case Empty -> Nothing -- This assumes that there are no empty chunks:- Node _ c Empty _ _ -> Just $ T.last $ TL.toText c- Node _ _ r _ _ -> lastChar r+ Node _ c Empty _ -> Just $ T.last $ TL.toText c+ Node _ _ r _ -> lastChar r -- | Equivalent to 'Data.List.length' . 'lines', but in logarithmic time. --@@ -277,16 +326,25 @@ splitAt :: HasCallStack => Word -> Rope -> (Rope, Rope) splitAt !len = \case Empty -> (Empty, Empty)- Node l c r _ _+ Node l c r m | len <= ll -> case splitAt len l of- (before, after) -> (before, node after c r)- | len <= llc -> case TL.splitAt (len - ll) c of- (before, after) -> (l |> before, after <| r)+ (before, after) -> (before, node after c cm r)+ | len <= llc -> do+ let i = len - ll+ case TL.splitAt i c of+ (before, after) -> do+ let beforeMetrics = Metrics+ { _metricsNewlines = TL.newlines before+ , _metricsCharLen = i+ }+ let afterMetrics = subMetrics cm beforeMetrics+ (snoc l before beforeMetrics, cons after afterMetrics r) | otherwise -> case splitAt (len - llc) r of- (before, after) -> (node l c before, after)+ (before, after) -> (node l c cm before, after) where ll = length l- llc = ll + TL.length c+ llc = ll + _metricsCharLen cm+ cm = subMetrics m (metrics l <> metrics r) -- | Split at given line, logarithmic time. --@@ -297,32 +355,17 @@ splitAtLine :: HasCallStack => Word -> Rope -> (Rope, Rope) splitAtLine !len = \case Empty -> (Empty, Empty)- Node l c r _ _+ Node l c r m | len <= ll -> case splitAtLine len l of- (before, after) -> (before, node after c r)+ (before, after) -> (before, node after c cm r) | len <= llc -> case TL.splitAtLine (len - ll) c of- (before, after) -> (l |> before, after <| r)+ (before, after) -> (snoc l before (linesMetrics before), cons after (linesMetrics after) r) | otherwise -> case splitAtLine (len - llc) r of- (before, after) -> (node l c before, after)+ (before, after) -> (node l c cm before, after) where- ll = TL.posLine (lengthAsPosition l)- llc = ll + TL.posLine (TL.lengthAsPosition c)--subOnRope :: Rope -> Position -> Position -> Position-subOnRope rp (Position xl xc) (Position yl yc) = case xl `compare` yl of- GT -> Position (xl - yl) xc- EQ -> Position 0 (xc - yc)- LT -> Position 0 (xc - length rp')- where- (_, rp') = splitAtLine xl rp--subOnLines :: TL.TextLines -> Position -> Position -> Position-subOnLines tl (Position xl xc) (Position yl yc) = case xl `compare` yl of- GT -> Position (xl - yl) xc- EQ -> Position 0 (xc - yc)- LT -> Position 0 (xc - TL.length tl')- where- (_, tl') = TL.splitAtLine xl tl+ ll = newlines l+ llc = ll + _metricsNewlines cm+ cm = subMetrics m (metrics l <> metrics r) -- | Combination of 'splitAtLine' and subsequent 'splitAt'. -- Time is linear in 'posColumn' and logarithmic in 'posLine'.@@ -342,25 +385,29 @@ -- ("f\n𐀀я","") -- splitAtPosition :: HasCallStack => Position -> Rope -> (Rope, Rope)-splitAtPosition (Position 0 0) = (mempty,)-splitAtPosition !len = \case- Empty -> (Empty, Empty)- Node l c r _ _- | len <= ll -> case splitAtPosition len l of- (before, after)- | null after -> case splitAtPosition len' (c <| r) of- (r', r'') -> (l <> r', r'')- | otherwise -> (before, node after c r)- | len <= llc -> case TL.splitAtPosition len' c of- (before, after)- | TL.null after -> case splitAtPosition len'' r of- (r', r'') -> ((l |> c) <> r', r'')- | otherwise -> (l |> before, after <| r)- | otherwise -> case splitAtPosition len'' r of- (before, after) -> (node l c before, after)- where- ll = lengthAsPosition l- lc = TL.lengthAsPosition c- llc = ll <> lc- len' = subOnRope l len ll- len'' = subOnLines c len' lc+splitAtPosition (Position l c) rp = (beforeLine <> beforeColumn, afterColumn)+ where+ (beforeLine, afterLine) = splitAtLine l rp+ (beforeColumn, afterColumn) = splitAt c afterLine++-- | Get a line by its 0-based index.+-- Returns 'mempty' if the index is out of bounds.+-- The result doesn't contain @\\n@ characters.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\l -> getLine l "foo\nbar\n😊😊\n\n") [0..3]+-- ["foo","bar","😊😊",""]+--+-- @since 0.3+getLine :: Word -> Rope -> Rope+getLine lineIdx rp =+ case splitAt (length firstLine - 1) firstLine of+ (firstLineInit, firstLineLast)+ | isNewline firstLineLast -> firstLineInit+ _ -> firstLine+ where+ (_, afterIndex) = splitAtLine lineIdx rp+ (firstLine, _ ) = splitAtLine 1 afterIndex++isNewline :: Rope -> Bool+isNewline = (== T.singleton '\n') . toText
src/Data/Text/Utf16/Lines.hs view
@@ -15,6 +15,7 @@ , I.toText , I.null -- * Lines+ , I.getLine , I.lines , I.lengthInLines , I.splitAtLine
src/Data/Text/Utf16/Rope.hs view
@@ -28,6 +28,7 @@ , lines , lengthInLines , splitAtLine+ , getLine -- * UTF-16 code units , length , splitAt@@ -44,7 +45,7 @@ import Data.Function ((.), ($), on) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..))-import Data.Ord (Ord, compare, (<), (<=), Ordering(..))+import Data.Ord (Ord, compare, (<), (<=)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) import Data.Text (Text)@@ -53,6 +54,7 @@ import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Utf16.Lines (Position(..)) import qualified Data.Text.Utf16.Lines as TL+import qualified Data.Text.Lines.Internal as TL (newlines) import Data.Word (Word) import Text.Show (Show) @@ -67,21 +69,25 @@ -- | Rope of 'Text' chunks with logarithmic concatenation. -- This rope offers an interface, based on UTF-16 code units. -- Use "Data.Text.Rope", if you need code points,--- or "Data.Text.Utf16.Rope.Mixed", if you need both interfaces.+-- or "Data.Text.Mixed.Rope", if you need both interfaces. data Rope = Empty | Node- { _ropeLeft :: !Rope- , _ropeMiddle :: !TL.TextLines- , _ropeRight :: !Rope- , _ropeUtf16Len :: !Word- , _ropeUtf16LenAsPos :: !Position+ { _ropeLeft :: !Rope+ , _ropeMiddle :: !TL.TextLines+ , _ropeRight :: !Rope+ , _ropeMetrics :: {-# UNPACK #-} !Metrics } +data Metrics = Metrics+ { _metricsNewlines :: !Word+ , _metricsUtf16Len :: !Word+ }+ instance NFData Rope where rnf Empty = () -- No need to deepseq strict fields, for which WHNF = NF- rnf (Node l _ r _ _) = rnf l `seq` rnf r+ rnf (Node l _ r _) = rnf l `seq` rnf r instance Eq Rope where (==) = (==) `on` toLazyText@@ -89,7 +95,32 @@ instance Ord Rope where compare = compare `on` toLazyText +instance Semigroup Metrics where+ Metrics nls1 u1 <> Metrics nls2 u2 =+ Metrics (nls1 + nls2) (u1 + u2)+ {-# INLINE (<>) #-}++instance Monoid Metrics where+ mempty = Metrics 0 0+ mappend = (<>)++subMetrics :: Metrics -> Metrics -> Metrics+subMetrics (Metrics nls1 u1) (Metrics nls2 u2) =+ Metrics (nls1 - nls2) (u1 - u2)++metrics :: Rope -> Metrics+metrics = \case+ Empty -> mempty+ Node _ _ _ m -> m++linesMetrics :: TL.TextLines -> Metrics+linesMetrics tl = Metrics+ { _metricsNewlines = TL.newlines tl+ , _metricsUtf16Len = TL.length tl+ }+ #ifdef DEBUG+deriving instance Show Metrics deriving instance Show Rope #else instance Show Rope where@@ -113,13 +144,29 @@ -- >>> Data.Text.Rope.length "fя𐀀" -- 3 length :: Rope -> Word-length = \case- Empty -> 0- Node _ _ _ w _ -> w+length = _metricsUtf16Len . metrics --- | Measure text length as an amount of lines and columns, O(1).+-- | The number of newline characters, O(1). -- -- >>> :set -XOverloadedStrings+-- >>> newlines ""+-- 0+-- >>> newlines "foo"+-- 0+-- >>> newlines "foo\n"+-- 1+-- >>> newlines "foo\n\n"+-- 2+-- >>> newlines "foo\nbar"+-- 1+--+newlines :: Rope -> Word+newlines = _metricsNewlines . metrics++-- | Measure text length as an amount of lines and columns.+-- Time is linear in the length of the last line.+--+-- >>> :set -XOverloadedStrings -- >>> lengthAsPosition "f𐀀" -- Position {posLine = 0, posColumn = 3} -- >>> lengthAsPosition "f\n𐀀"@@ -128,57 +175,59 @@ -- Position {posLine = 2, posColumn = 0} -- lengthAsPosition :: Rope -> Position-lengthAsPosition = \case- Empty -> mempty- Node _ _ _ _ p -> p+lengthAsPosition rp =+ Position nls (length line)+ where+ nls = newlines rp+ (_, line) = splitAtLine nls rp instance Semigroup Rope where Empty <> t = t t <> Empty = t- Node l1 c1 r1 u1 p1 <> Node l2 c2 r2 u2 p2 = defragment+ Node l1 c1 r1 m1 <> Node l2 c2 r2 m2 = defragment l1 c1- (Node (r1 <> l2) c2 r2 (length r1 + u2) (lengthAsPosition r1 <> p2))- (u1 + u2)- (p1 <> p2)+ (Node (r1 <> l2) c2 r2 (metrics r1 <> m2))+ (m1 <> m2) instance Monoid Rope where mempty = Empty mappend = (<>) -defragment :: HasCallStack => Rope -> TL.TextLines -> Rope -> Word -> Position -> Rope-defragment !l !c !r !u !p+defragment :: HasCallStack => Rope -> TL.TextLines -> Rope -> Metrics -> Rope+defragment !l !c !r !m #ifdef DEBUG | TL.null c = error "Data.Text.Lines: violated internal invariant" #endif- | u < DEFRAGMENTATION_THRESHOLD- = Node Empty (toTextLines rp) Empty u p+ | _metricsUtf16Len m < DEFRAGMENTATION_THRESHOLD+ = Node Empty (toTextLines rp) Empty m | otherwise = rp where- rp = Node l c r u p+ rp = Node l c r m -- | Create from 'TL.TextLines', linear time. fromTextLines :: TL.TextLines -> Rope fromTextLines tl | TL.null tl = Empty- | otherwise = Node Empty tl Empty (TL.length tl) (TL.lengthAsPosition tl)+ | otherwise = Node Empty tl Empty (linesMetrics tl) -node :: HasCallStack => Rope -> TL.TextLines -> Rope -> Rope-node l c r = defragment l c r totalLength totalLengthAsPosition- where- totalLength = length l + TL.length c + length r- totalLengthAsPosition = lengthAsPosition l <> TL.lengthAsPosition c <> lengthAsPosition r+-- | Create a 'Node', defragmenting it if necessary. The 'Metrics' argument is+-- the computed metrics of the 'TL.TextLines' argument.+node :: HasCallStack => Rope -> TL.TextLines -> Metrics -> Rope -> Rope+node l c cm r = defragment l c r (metrics l <> cm <> metrics r) -(|>) :: Rope -> TL.TextLines -> Rope-tr |> tl+-- | Append a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+snoc :: Rope -> TL.TextLines -> Metrics -> Rope+snoc tr tl tlm | TL.null tl = tr- | otherwise = node tr tl Empty+ | otherwise = node tr tl tlm Empty -(<|) :: TL.TextLines -> Rope -> Rope-tl <| tr+-- | Prepend a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+cons :: TL.TextLines -> Metrics -> Rope -> Rope+cons tl tlm tr | TL.null tl = tr- | otherwise = node Empty tl tr+ | otherwise = node Empty tl tlm tr -- | Create from 'Text', linear time. fromText :: Text -> Rope@@ -189,7 +238,7 @@ where go = \case Empty -> mempty- Node l c r _ _ -> go l `mappend` f c `mappend` go r+ Node l c r _ -> go l `mappend` f c `mappend` go r data Lines = Lines ![Text] !Bool @@ -230,8 +279,8 @@ lastChar = \case Empty -> Nothing -- This assumes that there are no empty chunks:- Node _ c Empty _ _ -> Just $ T.last $ TL.toText c- Node _ _ r _ _ -> lastChar r+ Node _ c Empty _ -> Just $ T.last $ TL.toText c+ Node _ _ r _ -> lastChar r -- | Equivalent to 'Data.List.length' . 'lines', but in logarithmic time. --@@ -277,19 +326,28 @@ splitAt :: HasCallStack => Word -> Rope -> Maybe (Rope, Rope) splitAt !len = \case Empty -> Just (Empty, Empty)- Node l c r _ _+ Node l c r m | len <= ll -> case splitAt len l of Nothing -> Nothing- Just (before, after) -> Just (before, node after c r)- | len <= llc -> case TL.splitAt (len - ll) c of- Nothing -> Nothing- Just (before, after) -> Just (l |> before, after <| r)+ Just (before, after) -> Just (before, node after c cm r)+ | len <= llc -> do+ let i = len - ll+ case TL.splitAt i c of+ Nothing -> Nothing+ Just (before, after) -> do+ let beforeMetrics = Metrics+ { _metricsNewlines = TL.newlines before+ , _metricsUtf16Len = i+ }+ let afterMetrics = subMetrics cm beforeMetrics+ Just (snoc l before beforeMetrics, cons after afterMetrics r) | otherwise -> case splitAt (len - llc) r of Nothing -> Nothing- Just (before, after) -> Just (node l c before, after)+ Just (before, after) -> Just (node l c cm before, after) where ll = length l- llc = ll + TL.length c+ llc = ll + _metricsUtf16Len cm+ cm = subMetrics m (metrics l <> metrics r) -- | Split at given line, logarithmic time. --@@ -300,32 +358,17 @@ splitAtLine :: HasCallStack => Word -> Rope -> (Rope, Rope) splitAtLine !len = \case Empty -> (Empty, Empty)- Node l c r _ _+ Node l c r m | len <= ll -> case splitAtLine len l of- (before, after) -> (before, node after c r)+ (before, after) -> (before, node after c cm r) | len <= llc -> case TL.splitAtLine (len - ll) c of- (before, after) -> (l |> before, after <| r)+ (before, after) -> (snoc l before (linesMetrics before), cons after (linesMetrics after) r) | otherwise -> case splitAtLine (len - llc) r of- (before, after) -> (node l c before, after)+ (before, after) -> (node l c cm before, after) where- ll = TL.posLine (lengthAsPosition l)- llc = ll + TL.posLine (TL.lengthAsPosition c)--subOnRope :: Rope -> Position -> Position -> Position-subOnRope rp (Position xl xc) (Position yl yc) = case xl `compare` yl of- GT -> Position (xl - yl) xc- EQ -> Position 0 (xc - yc)- LT -> Position 0 (xc - length rp')- where- (_, rp') = splitAtLine xl rp--subOnLines :: TL.TextLines -> Position -> Position -> Position-subOnLines tl (Position xl xc) (Position yl yc) = case xl `compare` yl of- GT -> Position (xl - yl) xc- EQ -> Position 0 (xc - yc)- LT -> Position 0 (xc - TL.length tl')- where- (_, tl') = TL.splitAtLine xl tl+ ll = newlines l+ llc = ll + _metricsNewlines cm+ cm = subMetrics m (metrics l <> metrics r) -- | Combination of 'splitAtLine' and subsequent 'splitAt'. -- Time is linear in 'posColumn' and logarithmic in 'posLine'.@@ -345,30 +388,29 @@ -- Just ("f\n𐀀","я") -- splitAtPosition :: HasCallStack => Position -> Rope -> Maybe (Rope, Rope)-splitAtPosition (Position 0 0) = Just . (mempty,)-splitAtPosition !len = \case- Empty -> Just (Empty, Empty)- Node l c r _ _- | len <= ll -> case splitAtPosition len l of- Nothing -> Nothing- Just (before, after)- | null after -> case splitAtPosition len' (c <| r) of- Nothing -> Nothing- Just (r', r'') -> Just (l <> r', r'')- | otherwise -> Just (before, node after c r)- | len <= llc -> case TL.splitAtPosition len' c of- Nothing -> Nothing- Just (before, after)- | TL.null after -> case splitAtPosition len'' r of- Nothing -> Nothing- Just (r', r'') -> Just ((l |> c) <> r', r'')- | otherwise -> Just (l |> before, after <| r)- | otherwise -> case splitAtPosition len'' r of- Nothing -> Nothing- Just (before, after) -> Just (node l c before, after)- where- ll = lengthAsPosition l- lc = TL.lengthAsPosition c- llc = ll <> lc- len' = subOnRope l len ll- len'' = subOnLines c len' lc+splitAtPosition (Position l c) rp = do+ let (beforeLine, afterLine) = splitAtLine l rp+ (beforeColumn, afterColumn) <- splitAt c afterLine+ Just (beforeLine <> beforeColumn, afterColumn)++-- | Get a line by its 0-based index.+-- Returns 'mempty' if the index is out of bounds.+-- The result doesn't contain @\\n@ characters.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\l -> getLine l "foo\nbar\n😊😊\n\n") [0..3]+-- ["foo","bar","😊😊",""]+--+-- @since 0.3+getLine :: Word -> Rope -> Rope+getLine lineIdx rp =+ case splitAt (length firstLine - 1) firstLine of+ Just (firstLineInit, firstLineLast)+ | isNewline firstLineLast -> firstLineInit+ _ -> firstLine+ where+ (_, afterIndex) = splitAtLine lineIdx rp+ (firstLine, _ ) = splitAtLine 1 afterIndex++isNewline :: Rope -> Bool+isNewline = (== T.singleton '\n') . toText
src/Data/Text/Utf16/Rope/Mixed.hs view
@@ -2,490 +2,30 @@ -- Copyright: (c) 2021-2022 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}--#ifdef DEBUG-#define DEFRAGMENTATION_THRESHOLD 4-#else-#define DEFRAGMENTATION_THRESHOLD 4096-#endif+--+-- @since 0.2 module Data.Text.Utf16.Rope.Mixed- ( Rope- , fromText- , fromTextLines- , toText- , toTextLines- , null+ ( Mixed.Rope+ , Mixed.fromText+ , Mixed.fromTextLines+ , Mixed.toText+ , Mixed.toTextLines+ , Mixed.null -- * Lines- , lines- , lengthInLines- , splitAtLine+ , Mixed.lines+ , Mixed.lengthInLines+ , Mixed.splitAtLine -- * Code points- , charLength- , charSplitAt- , charLengthAsPosition- , charSplitAtPosition+ , Mixed.charLength+ , Mixed.charSplitAt+ , Mixed.charLengthAsPosition+ , Mixed.charSplitAtPosition -- * UTF-16 code units- , utf16Length- , utf16SplitAt- , utf16LengthAsPosition- , utf16SplitAtPosition+ , Mixed.utf16Length+ , Mixed.utf16SplitAt+ , Mixed.utf16LengthAsPosition+ , Mixed.utf16SplitAtPosition ) where -import Prelude ((-), (+), seq)-import Control.DeepSeq (NFData, rnf)-import Data.Bool (Bool(..), otherwise)-import Data.Char (Char)-import Data.Eq (Eq, (==))-import Data.Function ((.), ($), on)-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord, compare, (<), (<=), Ordering(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TextLazy-import qualified Data.Text.Lazy.Builder as Builder-import Data.Text.Lines.Internal (TextLines)-import qualified Data.Text.Lines.Internal as TL (null, fromText, toText, lines, splitAtLine)-import qualified Data.Text.Lines as Char-import qualified Data.Text.Utf16.Lines as Utf16-import Data.Word (Word)-import Text.Show (Show)--#ifdef DEBUG-import Prelude (error)-import GHC.Stack (HasCallStack)-#else-#define HasCallStack ()-import Text.Show (show)-#endif---- | Rope of 'Text' chunks with logarithmic concatenation.--- This rope offers two interfaces: one based on code points--- and another one based on UTF-16 code units. This comes with a price--- of double bookkeeping and is less performant than "Data.Text.Rope"--- or "Data.Text.Utf16.Rope".-data Rope- = Empty- | Node- { _ropeLeft :: !Rope- , _ropeMiddle :: !TextLines- , _ropeRight :: !Rope- , _ropeCharLen :: !Word- , _ropeCharLenAsPos :: !Char.Position- , _ropeUtf16Len :: !Word- , _ropeUtf16LenAsPos :: !Utf16.Position- }--instance NFData Rope where- rnf Empty = ()- -- No need to deepseq strict fields, for which WHNF = NF- rnf (Node l _ r _ _ _ _) = rnf l `seq` rnf r--instance Eq Rope where- (==) = (==) `on` toLazyText--instance Ord Rope where- compare = compare `on` toLazyText--#ifdef DEBUG-deriving instance Show Rope-#else-instance Show Rope where- show = show . toLazyText-#endif--instance IsString Rope where- fromString = fromTextLines . fromString---- | Check whether a rope is empty, O(1).-null :: Rope -> Bool-null = \case- Empty -> True- Node{} -> False---- | Length in code points, similar to @Data.Text.@'Data.Text.length', O(1).------ >>> :set -XOverloadedStrings--- >>> charLength "fя𐀀"--- 3----charLength :: Rope -> Word-charLength = \case- Empty -> 0- Node _ _ _ w _ _ _ -> w---- | Length in UTF-16 code units, O(1).------ >>> :set -XOverloadedStrings--- >>> utf16Length "fя𐀀"--- 4----utf16Length :: Rope -> Word-utf16Length = \case- Empty -> 0- Node _ _ _ _ _ w _ -> w---- | Measure text length as an amount of lines and columns, O(1).------ >>> :set -XOverloadedStrings--- >>> charLengthAsPosition "f𐀀"--- Position {posLine = 0, posColumn = 2}--- >>> charLengthAsPosition "f\n𐀀"--- Position {posLine = 1, posColumn = 1}--- >>> charLengthAsPosition "f\n𐀀\n"--- Position {posLine = 2, posColumn = 0}----charLengthAsPosition :: Rope -> Char.Position-charLengthAsPosition = \case- Empty -> mempty- Node _ _ _ _ p _ _ -> p---- | Measure text length as an amount of lines and columns, O(1).------ >>> :set -XOverloadedStrings--- >>> utf16LengthAsPosition "f𐀀"--- Position {posLine = 0, posColumn = 3}--- >>> utf16LengthAsPosition "f\n𐀀"--- Position {posLine = 1, posColumn = 2}--- >>> utf16LengthAsPosition "f\n𐀀\n"--- Position {posLine = 2, posColumn = 0}----utf16LengthAsPosition :: Rope -> Utf16.Position-utf16LengthAsPosition = \case- Empty -> mempty- Node _ _ _ _ _ _ p -> p--instance Semigroup Rope where- Empty <> t = t- t <> Empty = t- Node l1 c1 r1 u1 p1 u1' p1' <> Node l2 c2 r2 u2 p2 u2' p2' = defragment- l1- c1- (Node (r1 <> l2) c2 r2 (charLength r1 + u2) (charLengthAsPosition r1 <> p2) (utf16Length r1 + u2') (utf16LengthAsPosition r1 <> p2'))- (u1 + u2)- (p1 <> p2)- (u1' + u2')- (p1' <> p2')--instance Monoid Rope where- mempty = Empty- mappend = (<>)--defragment :: HasCallStack => Rope -> TextLines -> Rope -> Word -> Char.Position -> Word -> Utf16.Position -> Rope-defragment !l !c !r !u !p !u' !p'-#ifdef DEBUG- | TL.null c = error "Data.Text.Lines: violated internal invariant"-#endif- | u < DEFRAGMENTATION_THRESHOLD- = Node Empty (toTextLines rp) Empty u p u' p'- | otherwise- = rp- where- rp = Node l c r u p u' p'---- | Create from 'TextLines', linear time.-fromTextLines :: TextLines -> Rope-fromTextLines tl- | TL.null tl = Empty- | otherwise = Node Empty tl Empty (Char.length tl) (Char.lengthAsPosition tl) (Utf16.length tl) (Utf16.lengthAsPosition tl)--node :: HasCallStack => Rope -> TextLines -> Rope -> Rope-node l c r = defragment l c r totalLength totalLengthAsPosition totalLength' totalLengthAsPosition'- where- totalLength = charLength l + Char.length c + charLength r- totalLengthAsPosition = charLengthAsPosition l <> Char.lengthAsPosition c <> charLengthAsPosition r- totalLength' = utf16Length l + Utf16.length c + utf16Length r- totalLengthAsPosition' = utf16LengthAsPosition l <> Utf16.lengthAsPosition c <> utf16LengthAsPosition r--(|>) :: Rope -> TextLines -> Rope-tr |> tl- | TL.null tl = tr- | otherwise = node tr tl Empty--(<|) :: TextLines -> Rope -> Rope-tl <| tr- | TL.null tl = tr- | otherwise = node Empty tl tr---- | Create from 'Text', linear time.-fromText :: Text -> Rope-fromText = fromTextLines . TL.fromText--foldMapRope :: Monoid a => (TextLines -> a) -> Rope -> a-foldMapRope f = go- where- go = \case- Empty -> mempty- Node l c r _ _ _ _ -> go l `mappend` f c `mappend` go r--data Lines = Lines ![Text] !Bool--instance Semigroup Lines where- Lines [] _ <> ls = ls- ls <> Lines [] _ = ls- Lines xs x <> Lines ys y = Lines (if x then xs <> ys else go xs ys) y- where- go [] vs = vs- go [u] (v : vs) = (u <> v) : vs- go (u : us) vs = u : go us vs--instance Monoid Lines where- mempty = Lines [] False- mappend = (<>)---- | Split into lines by @\\n@, similar to @Data.Text.@'Data.Text.lines'.--- Each line is produced in O(1).------ >>> :set -XOverloadedStrings--- >>> lines ""--- []--- >>> lines "foo"--- ["foo"]--- >>> lines "foo\n"--- ["foo"]--- >>> lines "foo\n\n"--- ["foo",""]--- >>> lines "foo\nbar"--- ["foo","bar"]----lines :: Rope -> [Text]-lines = (\(Lines ls _) -> ls) . foldMapRope- -- This assumes that there are no empty chunks:- (\tl -> Lines (TL.lines tl) (T.last (TL.toText tl) == '\n'))--lastChar :: Rope -> Maybe Char-lastChar = \case- Empty -> Nothing- -- This assumes that there are no empty chunks:- Node _ c Empty _ _ _ _ -> Just $ T.last $ TL.toText c- Node _ _ r _ _ _ _ -> lastChar r---- | Equivalent to 'Data.List.length' . 'lines', but in logarithmic time.------ >>> :set -XOverloadedStrings--- >>> lengthInLines ""--- 0--- >>> lengthInLines "foo"--- 1--- >>> lengthInLines "foo\n"--- 1--- >>> lengthInLines "foo\n\n"--- 2--- >>> lengthInLines "foo\nbar"--- 2------ If you do not care about ignoring the last newline character,--- you can use 'Char.posLine' . 'charLengthAsPosition' instead, which works in O(1).----lengthInLines :: Rope -> Word-lengthInLines rp = case lastChar rp of- Nothing -> 0- Just ch -> Char.posLine (charLengthAsPosition rp) + (if ch == '\n' then 0 else 1)---- | Glue chunks into 'TextLines', linear time.-toTextLines :: Rope -> TextLines-toTextLines = mconcat . foldMapRope (:[])--toLazyText :: Rope -> TextLazy.Text-toLazyText = foldMapRope (TextLazy.fromStrict . TL.toText)---- | Glue chunks into 'Text', linear time.-toText :: Rope -> Text-toText = TextLazy.toStrict . Builder.toLazyText . foldMapRope (Builder.fromText . TL.toText)---- | Split at given code point, similar to @Data.Text.@'Data.Text.splitAt'.--- Takes linear time.------ >>> :set -XOverloadedStrings--- >>> map (\c -> charSplitAt c "fя𐀀") [0..4]--- [("","fя𐀀"),("f","я𐀀"),("fя","𐀀"),("fя𐀀",""),("fя𐀀","")]----charSplitAt :: HasCallStack => Word -> Rope -> (Rope, Rope)-charSplitAt !len = \case- Empty -> (Empty, Empty)- Node l c r _ _ _ _- | len <= ll -> case charSplitAt len l of- (before, after) -> (before, node after c r)- | len <= llc -> case Char.splitAt (len - ll) c of- (before, after) -> (l |> before, after <| r)- | otherwise -> case charSplitAt (len - llc) r of- (before, after) -> (node l c before, after)- where- ll = charLength l- llc = ll + Char.length c---- | Split at given UTF-16 code unit.--- If requested number of code units splits a code point in half, return 'Nothing'.--- Takes linear time.------ >>> :set -XOverloadedStrings--- >>> map (\c -> utf16SplitAt c "fя𐀀") [0..4]--- [Just ("","fя𐀀"),Just ("f","я𐀀"),Just ("fя","𐀀"),Nothing,Just ("fя𐀀","")]----utf16SplitAt :: HasCallStack => Word -> Rope -> Maybe (Rope, Rope)-utf16SplitAt !len = \case- Empty -> Just (Empty, Empty)- Node l c r _ _ _ _- | len <= ll -> case utf16SplitAt len l of- Nothing -> Nothing- Just (before, after) -> Just (before, node after c r)- | len <= llc -> case Utf16.splitAt (len - ll) c of- Nothing -> Nothing- Just (before, after) -> Just (l |> before, after <| r)- | otherwise -> case utf16SplitAt (len - llc) r of- Nothing -> Nothing- Just (before, after) -> Just (node l c before, after)- where- ll = utf16Length l- llc = ll + Utf16.length c---- | Split at given line, logarithmic time.------ >>> :set -XOverloadedStrings--- >>> map (\l -> splitAtLine l "foo\nbar") [0..3]--- [("","foo\nbar"),("foo\n","bar"),("foo\nbar",""),("foo\nbar","")]----splitAtLine :: HasCallStack => Word -> Rope -> (Rope, Rope)-splitAtLine !len = \case- Empty -> (Empty, Empty)- Node l c r _ _ _ _- | len <= ll -> case splitAtLine len l of- (before, after) -> (before, node after c r)- | len <= llc -> case TL.splitAtLine (len - ll) c of- (before, after) -> (l |> before, after <| r)- | otherwise -> case splitAtLine (len - llc) r of- (before, after) -> (node l c before, after)- where- -- posLine is the same both in Char.lengthAsPosition and Utf16.lengthAsPosition- ll = Char.posLine (charLengthAsPosition l)- llc = ll + Char.posLine (Char.lengthAsPosition c)--charSubOnRope :: Rope -> Char.Position -> Char.Position -> Char.Position-charSubOnRope rp (Char.Position xl xc) (Char.Position yl yc) = case xl `compare` yl of- GT -> Char.Position (xl - yl) xc- EQ -> Char.Position 0 (xc - yc)- LT -> Char.Position 0 (xc - charLength rp')- where- (_, rp') = splitAtLine xl rp--utf16SubOnRope :: Rope -> Utf16.Position -> Utf16.Position -> Utf16.Position-utf16SubOnRope rp (Utf16.Position xl xc) (Utf16.Position yl yc) = case xl `compare` yl of- GT -> Utf16.Position (xl - yl) xc- EQ -> Utf16.Position 0 (xc - yc)- LT -> Utf16.Position 0 (xc - utf16Length rp')- where- (_, rp') = splitAtLine xl rp--charSubOnLines :: Char.TextLines -> Char.Position -> Char.Position -> Char.Position-charSubOnLines tl (Char.Position xl xc) (Char.Position yl yc) = case xl `compare` yl of- GT -> Char.Position (xl - yl) xc- EQ -> Char.Position 0 (xc - yc)- LT -> Char.Position 0 (xc - Char.length tl')- where- (_, tl') = Char.splitAtLine xl tl--utf16SubOnLines :: Utf16.TextLines -> Utf16.Position -> Utf16.Position -> Utf16.Position-utf16SubOnLines tl (Utf16.Position xl xc) (Utf16.Position yl yc) = case xl `compare` yl of- GT -> Utf16.Position (xl - yl) xc- EQ -> Utf16.Position 0 (xc - yc)- LT -> Utf16.Position 0 (xc - Utf16.length tl')- where- (_, tl') = Utf16.splitAtLine xl tl---- | Combination of 'splitAtLine' and subsequent 'charSplitAt'.--- Time is linear in 'Char.posColumn' and logarithmic in 'Char.posLine'.------ >>> :set -XOverloadedStrings--- >>> charSplitAtPosition (Position 1 0) "f\n𐀀я"--- ("f\n","𐀀я")--- >>> charSplitAtPosition (Position 1 1) "f\n𐀀я"--- ("f\n𐀀","я")--- >>> charSplitAtPosition (Position 1 2) "f\n𐀀я"--- ("f\n𐀀я","")--- >>> charSplitAtPosition (Position 0 2) "f\n𐀀я"--- ("f\n","𐀀я")--- >>> charSplitAtPosition (Position 0 3) "f\n𐀀я"--- ("f\n𐀀","я")--- >>> charSplitAtPosition (Position 0 4) "f\n𐀀я"--- ("f\n𐀀я","")----charSplitAtPosition :: HasCallStack => Char.Position -> Rope -> (Rope, Rope)-charSplitAtPosition (Char.Position 0 0) = (mempty,)-charSplitAtPosition !len = \case- Empty -> (Empty, Empty)- Node l c r _ _ _ _- | len <= ll -> case charSplitAtPosition len l of- (before, after)- | null after -> case charSplitAtPosition len' (c <| r) of- (r', r'') -> (l <> r', r'')- | otherwise -> (before, node after c r)- | len <= llc -> case Char.splitAtPosition len' c of- (before, after)- | TL.null after -> case charSplitAtPosition len'' r of- (r', r'') -> ((l |> c) <> r', r'')- | otherwise -> (l |> before, after <| r)- | otherwise -> case charSplitAtPosition len'' r of- (before, after) -> (node l c before, after)- where- ll = charLengthAsPosition l- lc = Char.lengthAsPosition c- llc = ll <> lc- len' = charSubOnRope l len ll- len'' = charSubOnLines c len' lc---- | Combination of 'splitAtLine' and subsequent 'utf16SplitAt'.--- Time is linear in 'Utf16.posColumn' and logarithmic in 'Utf16.posLine'.------ >>> :set -XOverloadedStrings--- >>> utf16SplitAtPosition (Position 1 0) "f\n𐀀я"--- Just ("f\n","𐀀я")--- >>> utf16SplitAtPosition (Position 1 1) "f\n𐀀я"--- Nothing--- >>> utf16SplitAtPosition (Position 1 2) "f\n𐀀я"--- Just ("f\n𐀀","я")--- >>> utf16SplitAtPosition (Position 0 2) "f\n𐀀я"--- Just ("f\n","𐀀я")--- >>> utf16SplitAtPosition (Position 0 3) "f\n𐀀я"--- Nothing--- >>> utf16SplitAtPosition (Position 0 4) "f\n𐀀я"--- Just ("f\n𐀀","я")----utf16SplitAtPosition :: HasCallStack => Utf16.Position -> Rope -> Maybe (Rope, Rope)-utf16SplitAtPosition (Utf16.Position 0 0) = Just . (mempty,)-utf16SplitAtPosition !len = \case- Empty -> Just (Empty, Empty)- Node l c r _ _ _ _- | len <= ll -> case utf16SplitAtPosition len l of- Nothing -> Nothing- Just (before, after)- | null after -> case utf16SplitAtPosition len' (c <| r) of- Nothing -> Nothing- Just (r', r'') -> Just (l <> r', r'')- | otherwise -> Just (before, node after c r)- | len <= llc -> case Utf16.splitAtPosition len' c of- Nothing -> Nothing- Just (before, after)- | Utf16.null after -> case utf16SplitAtPosition len'' r of- Nothing -> Nothing- Just (r', r'') -> Just ((l |> c) <> r', r'')- | otherwise -> Just (l |> before, after <| r)- | otherwise -> case utf16SplitAtPosition len'' r of- Nothing -> Nothing- Just (before, after) -> Just (node l c before, after)- where- ll = utf16LengthAsPosition l- lc = Utf16.lengthAsPosition c- llc = ll <> lc- len' = utf16SubOnRope l len ll- len'' = utf16SubOnLines c len' lc+import qualified Data.Text.Mixed.Rope as Mixed
+ src/Data/Text/Utf8/Lines.hs view
@@ -0,0 +1,196 @@+-- |+-- Licence: BSD3+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- @since 0.3++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UnliftedFFITypes #-}++module Data.Text.Utf8.Lines+ ( I.TextLines+ , I.fromText+ , I.toText+ , I.null+ -- * Lines+ , I.getLine+ , I.lines+ , I.lengthInLines+ , I.splitAtLine+ -- * UTF-8 code units+ , length+ , splitAt+ , Position(..)+ , lengthAsPosition+ , splitAtPosition+ ) where++import Prelude ((+), (-), seq)+import Control.DeepSeq (NFData, rnf)+import Data.Bool (otherwise)+import Data.Eq (Eq, (==))+import Data.Function ((.), ($))+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord, (<=), (>), (>=))+import Data.Semigroup (Semigroup(..))+import qualified Data.Text.Array as TA+import Data.Text.Internal (Text(..))+import qualified Data.Text.Lines.Internal as I+import qualified Data.Vector.Unboxed as U+import Data.Word (Word)+import Text.Show (Show)++#if MIN_VERSION_text(2,0,0)+import Data.Bits ((.&.))+#else+import Prelude (fromIntegral)+import Foreign.C.Types (CSize(..))+import GHC.Exts (ByteArray#)+import System.IO (IO)+import System.IO.Unsafe (unsafeDupablePerformIO)+import System.Posix.Types (CSsize(..))+#endif++#ifdef DEBUG+import GHC.Stack (HasCallStack)+#else+#define HasCallStack ()+#endif++lengthTextUtf8 :: Text -> Word+#if MIN_VERSION_text(2,0,0)+lengthTextUtf8 (Text _ _ len) = I.intToWord len+#else+lengthTextUtf8 (Text (TA.Array arr) off len) = fromIntegral $ unsafeDupablePerformIO $+ lengthUtf16AsUtf8 arr (fromIntegral off) (fromIntegral len)++foreign import ccall unsafe "_hs_text_lines_length_utf16_as_utf8" lengthUtf16AsUtf8+ :: ByteArray# -> CSize -> CSize -> IO CSsize+#endif++-- | Length in UTF-8 code units aka bytes.+-- Takes linear time.+--+-- >>> :set -XOverloadedStrings+-- >>> length "fя𐀀"+-- 7+-- >>> Data.Text.Lines.length "fя𐀀"+-- 3+--+length :: I.TextLines -> Word+length = lengthTextUtf8 . I.toText++-- | Represent a position in a text.+data Position = Position+ { posLine :: !Word -- ^ Line.+ , posColumn :: !Word -- ^ Column in UTF-8 code units aka bytes.+ } deriving (Eq, Ord, Show)++instance NFData Position where+ rnf = (`seq` ())++-- | Associativity does not hold when 'posLine' overflows.+instance Semigroup Position where+ Position l1 c1 <> Position l2 c2 =+ Position (l1 + l2) (if l2 == 0 then c1 + c2 else c2)++instance Monoid Position where+ mempty = Position 0 0+ mappend = (<>)++-- | Measure text length as an amount of lines and columns.+-- Time is proportional to the length of the last line.+--+-- >>> :set -XOverloadedStrings+-- >>> lengthAsPosition "f𐀀"+-- Position {posLine = 0, posColumn = 7}+-- >>> lengthAsPosition "f\n𐀀"+-- Position {posLine = 1, posColumn = 4}+-- >>> lengthAsPosition "f\n𐀀\n"+-- Position {posLine = 2, posColumn = 0}+--+lengthAsPosition+ :: I.TextLines+ -> Position+lengthAsPosition (I.TextLines (Text arr off len) nls) = Position+ { posLine = I.intToWord $ U.length nls+ , posColumn = lengthTextUtf8 $ Text arr nl (off + len - nl)+ }+ where+ nl = if U.null nls then off else U.last nls + 1++splitTextAtUtf8Index :: Word -> Text -> Maybe (Text, Text)+splitTextAtUtf8Index k t@(Text arr off len)+ | k <= 0 = Just (Text arr off 0, t)+#if MIN_VERSION_text(2,0,0)+ | k >= I.intToWord len = Just (t, mempty)+ | otherwise = if c .&. 0xc0 == 0x80 then Nothing else Just+ (Text arr off k', Text arr (off + k') (len - k'))+ where+ k' = I.wordToInt k+ c = TA.unsafeIndex arr (off + k')+#else+ | o >= 0 = Just (Text arr off o, Text arr (off + o) (len - o))+ | otherwise = Nothing+ where+ !(TA.Array arr#) = arr+ o = fromIntegral $ unsafeDupablePerformIO $+ takeUtf16AsUtf8 arr# (fromIntegral off) (fromIntegral len) (fromIntegral k)++foreign import ccall unsafe "_hs_text_lines_take_utf16_as_utf8" takeUtf16AsUtf8+ :: ByteArray# -> CSize -> CSize -> CSize -> IO CSsize+#endif++-- | Combination of 'I.splitAtLine' and subsequent 'splitAt'.+-- If requested number of code units splits a code point in half, return 'Nothing'.+-- Time is linear in 'posColumn', but does not depend on 'posLine'.+--+-- >>> :set -XOverloadedStrings+-- >>> splitAtPosition (Position 1 0) "f\n𐀀я"+-- Just ("f\n","𐀀я")+-- >>> splitAtPosition (Position 1 1) "f\n𐀀я"+-- Nothing+-- >>> splitAtPosition (Position 1 2) "f\n𐀀я"+-- Nothing+-- >>> splitAtPosition (Position 0 2) "f\n𐀀я"+-- Just ("f\n","𐀀я")+-- >>> splitAtPosition (Position 0 3) "f\n𐀀я"+-- Nothing+-- >>> splitAtPosition (Position 0 4) "f\n𐀀я"+-- Nothing+-- >>> splitAtPosition (Position 0 6) "f\n𐀀я"+-- Just ("f\n𐀀","я")+--+splitAtPosition+ :: HasCallStack+ => Position+ -> I.TextLines+ -> Maybe (I.TextLines, I.TextLines)+splitAtPosition (Position line column) (I.TextLines (Text arr off len) nls) =+ case splitTextAtUtf8Index column tx of+ Nothing -> Nothing+ Just (Text _ off' len', tz) -> let n = I.binarySearch nls (off' + len') in Just+ ( I.textLines (Text arr off (off' + len' - off)) (U.take n nls)+ , I.textLines tz (U.drop n nls))+ where+ arrLen = off + len+ nl+ | line <= 0 = off+ | line > I.intToWord (U.length nls) = arrLen+ | otherwise = nls U.! (I.wordToInt line - 1) + 1+ tx = Text arr nl (arrLen - nl)++-- | Split at given UTF-8 code unit aka byte.+-- If requested number of code units splits a code point in half, return 'Nothing'.+-- Takes linear time.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\c -> splitAt c "fя𐀀") [0..7]+-- [Just ("","fя𐀀"),Just ("f","я𐀀"),Nothing,Just ("fя","𐀀"),Nothing,Nothing,Nothing,Just ("fя𐀀","")]+--+splitAt :: HasCallStack => Word -> I.TextLines -> Maybe (I.TextLines, I.TextLines)+splitAt = splitAtPosition . Position 0
+ src/Data/Text/Utf8/Rope.hs view
@@ -0,0 +1,417 @@+-- |+-- Licence: BSD3+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- @since 0.3++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}++#ifdef DEBUG+#define DEFRAGMENTATION_THRESHOLD 4+#else+#define DEFRAGMENTATION_THRESHOLD 4096+#endif++module Data.Text.Utf8.Rope+ ( Rope+ , fromText+ , fromTextLines+ , toText+ , toTextLines+ , null+ -- * Lines+ , lines+ , lengthInLines+ , splitAtLine+ , getLine+ -- * UTF-8 code units+ , length+ , splitAt+ , Position(..)+ , lengthAsPosition+ , splitAtPosition+ ) where++import Prelude ((-), (+), seq)+import Control.DeepSeq (NFData, rnf)+import Data.Bool (Bool(..), otherwise)+import Data.Char (Char)+import Data.Eq (Eq, (==))+import Data.Function ((.), ($), on)+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord, compare, (<), (<=))+import Data.Semigroup (Semigroup(..))+import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TextLazy+import qualified Data.Text.Lazy.Builder as Builder+import Data.Text.Utf8.Lines (Position(..))+import qualified Data.Text.Utf8.Lines as TL+import qualified Data.Text.Lines.Internal as TL (newlines)+import Data.Word (Word)+import Text.Show (Show)++#ifdef DEBUG+import Prelude (error)+import GHC.Stack (HasCallStack)+#else+#define HasCallStack ()+import Text.Show (show)+#endif++-- | Rope of 'Text' chunks with logarithmic concatenation.+-- This rope offers an interface, based on UTF-8 code units.+-- Use "Data.Text.Rope", if you need code points,+-- or "Data.Text.Mixed.Rope", if you need both interfaces.+data Rope+ = Empty+ | Node+ { _ropeLeft :: !Rope+ , _ropeMiddle :: !TL.TextLines+ , _ropeRight :: !Rope+ , _ropeMetrics :: {-# UNPACK #-} !Metrics+ }++data Metrics = Metrics+ { _metricsNewlines :: !Word+ , _metricsUtf8Len :: !Word+ }++instance NFData Rope where+ rnf Empty = ()+ -- No need to deepseq strict fields, for which WHNF = NF+ rnf (Node l _ r _) = rnf l `seq` rnf r++instance Eq Rope where+ (==) = (==) `on` toLazyText++instance Ord Rope where+ compare = compare `on` toLazyText++instance Semigroup Metrics where+ Metrics nls1 u1 <> Metrics nls2 u2 =+ Metrics (nls1 + nls2) (u1 + u2)+ {-# INLINE (<>) #-}++instance Monoid Metrics where+ mempty = Metrics 0 0+ mappend = (<>)++subMetrics :: Metrics -> Metrics -> Metrics+subMetrics (Metrics nls1 u1) (Metrics nls2 u2) =+ Metrics (nls1 - nls2) (u1 - u2)++metrics :: Rope -> Metrics+metrics = \case+ Empty -> mempty+ Node _ _ _ m -> m++linesMetrics :: TL.TextLines -> Metrics+linesMetrics tl = Metrics+ { _metricsNewlines = TL.newlines tl+ , _metricsUtf8Len = TL.length tl+ }++#ifdef DEBUG+deriving instance Show Metrics+deriving instance Show Rope+#else+instance Show Rope where+ show = show . toLazyText+#endif++instance IsString Rope where+ fromString = fromTextLines . fromString++-- | Check whether a rope is empty, O(1).+null :: Rope -> Bool+null = \case+ Empty -> True+ Node{} -> False++-- | Length in UTF-8 code units aka bytes, O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> length "fя𐀀"+-- 7+-- >>> Data.Text.Rope.length "fя𐀀"+-- 3+length :: Rope -> Word+length = _metricsUtf8Len . metrics++-- | The number of newline characters, O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> newlines ""+-- 0+-- >>> newlines "foo"+-- 0+-- >>> newlines "foo\n"+-- 1+-- >>> newlines "foo\n\n"+-- 2+-- >>> newlines "foo\nbar"+-- 1+--+newlines :: Rope -> Word+newlines = _metricsNewlines . metrics++-- | Measure text length as an amount of lines and columns.+-- Time is linear in the length of the last line.+--+-- >>> :set -XOverloadedStrings+-- >>> lengthAsPosition "f𐀀"+-- Position {posLine = 0, posColumn = 5}+-- >>> lengthAsPosition "f\n𐀀"+-- Position {posLine = 1, posColumn = 4}+-- >>> lengthAsPosition "f\n𐀀\n"+-- Position {posLine = 2, posColumn = 0}+--+lengthAsPosition :: Rope -> Position+lengthAsPosition rp =+ Position nls (length line)+ where+ nls = newlines rp+ (_, line) = splitAtLine nls rp++instance Semigroup Rope where+ Empty <> t = t+ t <> Empty = t+ Node l1 c1 r1 m1 <> Node l2 c2 r2 m2 = defragment+ l1+ c1+ (Node (r1 <> l2) c2 r2 (metrics r1 <> m2))+ (m1 <> m2)++instance Monoid Rope where+ mempty = Empty+ mappend = (<>)++defragment :: HasCallStack => Rope -> TL.TextLines -> Rope -> Metrics -> Rope+defragment !l !c !r !m+#ifdef DEBUG+ | TL.null c = error "Data.Text.Lines: violated internal invariant"+#endif+ | _metricsUtf8Len m < DEFRAGMENTATION_THRESHOLD+ = Node Empty (toTextLines rp) Empty m+ | otherwise+ = rp+ where+ rp = Node l c r m++-- | Create from 'TL.TextLines', linear time.+fromTextLines :: TL.TextLines -> Rope+fromTextLines tl+ | TL.null tl = Empty+ | otherwise = Node Empty tl Empty (linesMetrics tl)++-- | Create a 'Node', defragmenting it if necessary. The 'Metrics' argument is+-- the computed metrics of the 'TL.TextLines' argument.+node :: HasCallStack => Rope -> TL.TextLines -> Metrics -> Rope -> Rope+node l c cm r = defragment l c r (metrics l <> cm <> metrics r)++-- | Append a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+snoc :: Rope -> TL.TextLines -> Metrics -> Rope+snoc tr tl tlm+ | TL.null tl = tr+ | otherwise = node tr tl tlm Empty++-- | Prepend a 'TL.TextLines' with the given 'Metrics' to a 'Rope'.+cons :: TL.TextLines -> Metrics -> Rope -> Rope+cons tl tlm tr+ | TL.null tl = tr+ | otherwise = node Empty tl tlm tr++-- | Create from 'Text', linear time.+fromText :: Text -> Rope+fromText = fromTextLines . TL.fromText++foldMapRope :: Monoid a => (TL.TextLines -> a) -> Rope -> a+foldMapRope f = go+ where+ go = \case+ Empty -> mempty+ Node l c r _ -> go l `mappend` f c `mappend` go r++data Lines = Lines ![Text] !Bool++instance Semigroup Lines where+ Lines [] _ <> ls = ls+ ls <> Lines [] _ = ls+ Lines xs x <> Lines ys y = Lines (if x then xs <> ys else go xs ys) y+ where+ go [] vs = vs+ go [u] (v : vs) = (u <> v) : vs+ go (u : us) vs = u : go us vs++instance Monoid Lines where+ mempty = Lines [] False+ mappend = (<>)++-- | Split into lines by @\\n@, similar to @Data.Text.@'Data.Text.lines'.+-- Each line is produced in O(1).+--+-- >>> :set -XOverloadedStrings+-- >>> lines ""+-- []+-- >>> lines "foo"+-- ["foo"]+-- >>> lines "foo\n"+-- ["foo"]+-- >>> lines "foo\n\n"+-- ["foo",""]+-- >>> lines "foo\nbar"+-- ["foo","bar"]+--+lines :: Rope -> [Text]+lines = (\(Lines ls _) -> ls) . foldMapRope+ -- This assumes that there are no empty chunks:+ (\tl -> Lines (TL.lines tl) (T.last (TL.toText tl) == '\n'))++lastChar :: Rope -> Maybe Char+lastChar = \case+ Empty -> Nothing+ -- This assumes that there are no empty chunks:+ Node _ c Empty _ -> Just $ T.last $ TL.toText c+ Node _ _ r _ -> lastChar r++-- | Equivalent to 'Data.List.length' . 'lines', but in logarithmic time.+--+-- >>> :set -XOverloadedStrings+-- >>> lengthInLines ""+-- 0+-- >>> lengthInLines "foo"+-- 1+-- >>> lengthInLines "foo\n"+-- 1+-- >>> lengthInLines "foo\n\n"+-- 2+-- >>> lengthInLines "foo\nbar"+-- 2+--+-- If you do not care about ignoring the last newline character,+-- you can use 'posLine' . 'lengthAsPosition' instead, which works in O(1).+--+lengthInLines :: Rope -> Word+lengthInLines rp = case lastChar rp of+ Nothing -> 0+ Just ch -> TL.posLine (lengthAsPosition rp) + (if ch == '\n' then 0 else 1)++-- | Glue chunks into 'TL.TextLines', linear time.+toTextLines :: Rope -> TL.TextLines+toTextLines = mconcat . foldMapRope (:[])++toLazyText :: Rope -> TextLazy.Text+toLazyText = foldMapRope (TextLazy.fromStrict . TL.toText)++-- | Glue chunks into 'Text', linear time.+toText :: Rope -> Text+toText = TextLazy.toStrict . Builder.toLazyText . foldMapRope (Builder.fromText . TL.toText)++-- | Split at given UTF-8 code unit aka byte.+-- If requested number of code units splits a code point in half, return 'Nothing'.+-- Takes linear time.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\c -> splitAt c "fя𐀀") [0..7]+-- [Just ("","fя𐀀"),Just ("f","я𐀀"),Nothing,Just ("fя","𐀀"),Nothing,Nothing,Nothing,Just ("fя𐀀","")]+--+splitAt :: HasCallStack => Word -> Rope -> Maybe (Rope, Rope)+splitAt !len = \case+ Empty -> Just (Empty, Empty)+ Node l c r m+ | len <= ll -> case splitAt len l of+ Nothing -> Nothing+ Just (before, after) -> Just (before, node after c cm r)+ | len <= llc -> do+ let i = len - ll+ case TL.splitAt i c of+ Nothing -> Nothing+ Just (before, after) -> do+ let beforeMetrics = Metrics+ { _metricsNewlines = TL.newlines before+ , _metricsUtf8Len = i+ }+ let afterMetrics = subMetrics cm beforeMetrics+ Just (snoc l before beforeMetrics, cons after afterMetrics r)+ | otherwise -> case splitAt (len - llc) r of+ Nothing -> Nothing+ Just (before, after) -> Just (node l c cm before, after)+ where+ ll = length l+ llc = ll + _metricsUtf8Len cm+ cm = subMetrics m (metrics l <> metrics r)++-- | Split at given line, logarithmic time.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\l -> splitAtLine l "foo\nbar") [0..3]+-- [("","foo\nbar"),("foo\n","bar"),("foo\nbar",""),("foo\nbar","")]+--+splitAtLine :: HasCallStack => Word -> Rope -> (Rope, Rope)+splitAtLine !len = \case+ Empty -> (Empty, Empty)+ Node l c r m+ | len <= ll -> case splitAtLine len l of+ (before, after) -> (before, node after c cm r)+ | len <= llc -> case TL.splitAtLine (len - ll) c of+ (before, after) -> (snoc l before (linesMetrics before), cons after (linesMetrics after) r)+ | otherwise -> case splitAtLine (len - llc) r of+ (before, after) -> (node l c cm before, after)+ where+ ll = newlines l+ llc = ll + _metricsNewlines cm+ cm = subMetrics m (metrics l <> metrics r)++-- | Combination of 'splitAtLine' and subsequent 'splitAt'.+-- Time is linear in 'posColumn' and logarithmic in 'posLine'.+--+-- >>> :set -XOverloadedStrings+-- >>> splitAtPosition (Position 1 0) "f\n𐀀я"+-- Just ("f\n","𐀀я")+-- >>> splitAtPosition (Position 1 1) "f\n𐀀я"+-- Nothing+-- >>> splitAtPosition (Position 1 4) "f\n𐀀я"+-- Just ("f\n𐀀","я")+-- >>> splitAtPosition (Position 0 2) "f\n𐀀я"+-- Just ("f\n","𐀀я")+-- >>> splitAtPosition (Position 0 3) "f\n𐀀я"+-- Nothing+-- >>> splitAtPosition (Position 0 6) "f\n𐀀я"+-- Just ("f\n𐀀","я")+--+splitAtPosition :: HasCallStack => Position -> Rope -> Maybe (Rope, Rope)+splitAtPosition (Position l c) rp = do+ let (beforeLine, afterLine) = splitAtLine l rp+ (beforeColumn, afterColumn) <- splitAt c afterLine+ Just (beforeLine <> beforeColumn, afterColumn)++-- | Get a line by its 0-based index.+-- Returns 'mempty' if the index is out of bounds.+-- The result doesn't contain @\\n@ characters.+--+-- >>> :set -XOverloadedStrings+-- >>> map (\l -> getLine l "foo\nbar\n😊😊\n\n") [0..3]+-- ["foo","bar","😊😊",""]+--+-- @since 0.3+getLine :: Word -> Rope -> Rope+getLine lineIdx rp =+ case splitAt (length firstLine - 1) firstLine of+ Just (firstLineInit, firstLineLast)+ | isNewline firstLineLast -> firstLineInit+ _ -> firstLine+ where+ (_, afterIndex) = splitAtLine lineIdx rp+ (firstLine, _ ) = splitAtLine 1 afterIndex++isNewline :: Rope -> Bool+isNewline = (== T.singleton '\n') . toText
test/CharLines.hs view
@@ -7,7 +7,7 @@ ( testSuite ) where -import Prelude (fromIntegral, maxBound, (-))+import Prelude (fromIntegral, maxBound, zipWith, (+), (-)) import Data.Bool ((||), not, (&&)) import Data.Function (($)) import qualified Data.List as L@@ -19,7 +19,7 @@ import Data.Tuple (snd) import Data.Word (Word) import Test.Tasty (testGroup, TestTree)-import Test.Tasty.QuickCheck (Small(..), testProperty, (===), applyFun, (.||.), (.&&.), (==>))+import Test.Tasty.QuickCheck (Positive (..), Small(..), applyFun, conjoin, testProperty, (===), (.||.), (.&&.), (==>)) import Utils () @@ -102,4 +102,13 @@ null z .||. length (snd (splitAtLine l y)) === c , testProperty "splitAtPosition 5" $ \i -> let (y, z) = splitAtPosition i mempty in y === mempty .&&. z === mempty++ , testProperty "forall i in bounds: getLine i x == lines x !! i" $+ \x -> let lns = lines x in+ conjoin $ zipWith (\idx ln -> getLine idx x === fromText ln) [0..] lns+ , testProperty "forall i out of bounds: getLine i x == mempty" $+ \x (Positive offset) ->+ let maxIdx = L.genericLength (lines x) - 1+ outOfBoundsIdx = maxIdx + offset+ in getLine outOfBoundsIdx x === mempty ]
test/CharRope.hs view
@@ -7,13 +7,15 @@ ( testSuite ) where -import Prelude ()+import Prelude ((+), (-)) import Data.Function (($)) import Data.Semigroup ((<>))+import Data.Monoid (mempty)+import qualified Data.List as L import qualified Data.Text.Lines as Lines import qualified Data.Text.Rope as Rope import Test.Tasty (testGroup, TestTree)-import Test.Tasty.QuickCheck (testProperty, (===), (.&&.))+import Test.Tasty.QuickCheck (Positive(..), conjoin, testProperty, (===), (.&&.)) import Utils () @@ -48,4 +50,13 @@ , testProperty "splitAtPosition 2" $ \i x -> case (Rope.splitAtPosition i x, Lines.splitAtPosition i (Lines.fromText $ Rope.toText x)) of ((y, z), (y', z')) -> Lines.fromText (Rope.toText y) === y' .&&. Lines.fromText (Rope.toText z) === z'++ , testProperty "forall i in bounds: getLine i x == lines x !! i" $+ \x -> let lns = Rope.lines x in+ conjoin $ L.zipWith (\idx ln -> Rope.getLine idx x === Rope.fromText ln) [0..] lns+ , testProperty "forall i out of bounds: getLine i x == mempty" $+ \x (Positive offset) ->+ let maxIdx = L.genericLength (Rope.lines x) - 1+ outOfBoundsIdx = maxIdx + offset+ in Rope.getLine outOfBoundsIdx x === mempty ]
test/Main.hs view
@@ -10,6 +10,8 @@ import qualified CharLines import qualified CharRope import qualified MixedRope+import qualified Utf8Lines+import qualified Utf8Rope import qualified Utf16Lines import qualified Utf16Rope @@ -22,6 +24,8 @@ main = defaultMain $ testGroup "All" [ CharLines.testSuite , CharRope.testSuite+ , Utf8Lines.testSuite+ , Utf8Rope.testSuite , Utf16Lines.testSuite , Utf16Rope.testSuite , MixedRope.testSuite
test/MixedRope.hs view
@@ -11,12 +11,15 @@ import Data.Bool (Bool(..), (&&)) import Data.Function (($)) import Data.Maybe (Maybe(..), isJust)+import Data.Monoid (mempty) import Data.Semigroup ((<>))+import qualified Data.List as L import qualified Data.Text.Lines as Char+import qualified Data.Text.Utf8.Lines as Utf8 import qualified Data.Text.Utf16.Lines as Utf16-import qualified Data.Text.Utf16.Rope.Mixed as Mixed+import qualified Data.Text.Mixed.Rope as Mixed import Test.Tasty (testGroup, TestTree)-import Test.Tasty.QuickCheck (testProperty, (===), property, (.&&.), counterexample)+import Test.Tasty.QuickCheck (Positive(..), conjoin, counterexample, property, testProperty, (===), (.&&.)) import Utils () @@ -27,6 +30,8 @@ , testProperty "charLength" $ \x -> Mixed.charLength x === Char.length (Mixed.toTextLines x)+ , testProperty "utf8Length" $+ \x -> Mixed.utf8Length x === Utf8.length (Mixed.toTextLines x) , testProperty "utf16Length" $ \x -> Mixed.utf16Length x === Utf16.length (Mixed.toTextLines x) @@ -47,6 +52,16 @@ \i x -> case (Mixed.charSplitAt i x, Char.splitAt i (Char.fromText $ Mixed.toText x)) of ((y, z), (y', z')) -> Char.fromText (Mixed.toText y) === y' .&&. Char.fromText (Mixed.toText z) === z' + , testProperty "utf8SplitAt 1" $+ \i x -> case Mixed.utf8SplitAt i x of+ Nothing -> property True+ Just (y, z) -> x === y <> z+ , testProperty "utf8SplitAt 2" $+ \i x -> case (Mixed.utf8SplitAt i x, Utf8.splitAt i (Utf8.fromText $ Mixed.toText x)) of+ (Nothing, Nothing) -> property True+ (Nothing, Just{}) -> counterexample "can split TextLines, but not Mixed" False+ (Just{}, Nothing) -> counterexample "can split Mixed, but not TextLines" False+ (Just (y, z), Just (y', z')) -> Utf8.fromText (Mixed.toText y) === y' .&&. Utf8.fromText (Mixed.toText z) === z' , testProperty "utf16SplitAt 1" $ \i x -> case Mixed.utf16SplitAt i x of Nothing -> property True@@ -69,6 +84,16 @@ \i x -> case (Mixed.charSplitAtPosition i x, Char.splitAtPosition i (Char.fromText $ Mixed.toText x)) of ((y, z), (y', z')) -> Char.fromText (Mixed.toText y) === y' .&&. Char.fromText (Mixed.toText z) === z' + , testProperty "utf8SplitAtPosition 1" $+ \i x -> case Mixed.utf8SplitAtPosition i x of+ Nothing -> property True+ Just (y, z) -> x === y <> z+ , testProperty "utf8SplitAtPosition 2" $+ \i x -> case (Mixed.utf8SplitAtPosition i x, Utf8.splitAtPosition i (Utf8.fromText $ Mixed.toText x)) of+ (Nothing, Nothing) -> property True+ (Nothing, Just{}) -> counterexample "can split TextLines, but not Mixed" False+ (Just{}, Nothing) -> counterexample "can split Mixed, but not TextLines" False+ (Just (y, z), Just (y', z')) -> Utf8.fromText (Mixed.toText y) === y' .&&. Utf8.fromText (Mixed.toText z) === z' , testProperty "utf16SplitAtPosition 1" $ \i x -> case Mixed.utf16SplitAtPosition i x of Nothing -> property True@@ -83,4 +108,13 @@ \i x -> case Mixed.utf16SplitAtPosition i x of Just{} -> True Nothing -> isJust (Mixed.utf16SplitAtPosition (i <> Utf16.Position 0 1) x)++ , testProperty "forall i in bounds: getLine i x == lines x !! i" $+ \x -> let lns = Mixed.lines x in+ conjoin $ L.zipWith (\idx ln -> Mixed.getLine idx x === Mixed.fromText ln) [0..] lns+ , testProperty "forall i out of bounds: getLine i x == mempty" $+ \x (Positive offset) ->+ let maxIdx = L.genericLength (Mixed.lines x) - 1+ outOfBoundsIdx = maxIdx + offset+ in Mixed.getLine outOfBoundsIdx x === mempty ]
test/Utf16Rope.hs view
@@ -11,11 +11,13 @@ import Data.Bool (Bool(..), (&&)) import Data.Function (($)) import Data.Maybe (Maybe(..), isJust)+import Data.Monoid (mempty) import Data.Semigroup ((<>))-import qualified Data.Text.Utf16.Lines as Lines +import qualified Data.List as L+import qualified Data.Text.Utf16.Lines as Lines import qualified Data.Text.Utf16.Rope as Rope import Test.Tasty (testGroup, TestTree)-import Test.Tasty.QuickCheck (testProperty, (===), property, (.&&.), counterexample)+import Test.Tasty.QuickCheck (Positive(..), conjoin, counterexample, property, testProperty, (===), (.&&.)) import Utils () @@ -66,4 +68,13 @@ \i x -> case Rope.splitAtPosition i x of Just{} -> True Nothing -> isJust (Rope.splitAtPosition (i <> Lines.Position 0 1) x)++ , testProperty "forall i in bounds: getLine i x == lines x !! i" $+ \x -> let lns = Rope.lines x in+ conjoin $ L.zipWith (\idx ln -> Rope.getLine idx x === Rope.fromText ln) [0..] lns+ , testProperty "forall i out of bounds: getLine i x == mempty" $+ \x (Positive offset) ->+ let maxIdx = L.genericLength (Rope.lines x) - 1+ outOfBoundsIdx = maxIdx + offset+ in Rope.getLine outOfBoundsIdx x === mempty ]
+ test/Utf8Lines.hs view
@@ -0,0 +1,118 @@+module Utf8Lines+ ( testSuite+ ) where++import Prelude ((-), maxBound)+import Data.Bool (Bool(..), (&&))+import Data.Function (($))+import qualified Data.List as L+import Data.Maybe (Maybe(..))+import Data.Monoid (mempty, mconcat)+import Data.Ord (min, (>=), (<))+import Data.Semigroup ((<>), stimes, stimesMonoid)+import qualified Data.Text as T+import Data.Text.Utf8.Lines+import Data.Tuple (snd)+import Data.Word (Word)+import Test.Tasty (testGroup, TestTree)+import Test.Tasty.QuickCheck (Small(..), testProperty, (===), property, (.||.), (.&&.), (==>))++import Utils++testSuite :: TestTree+testSuite = testGroup "Utf8 Lines"+ [ testProperty "toText . fromText" $+ \x -> toText (fromText x) === x++ , testProperty "null" $+ \x -> null x === T.null (toText x)++ , testProperty "TextLines associativity" $+ \x y z -> (x <> y) <> z === x <> (y <> z :: TextLines)+ , testProperty "TextLines mempty <>" $+ \x -> mempty <> x === (x :: TextLines)+ , testProperty "TextLines <> mempty" $+ \x -> x <> mempty === (x :: TextLines)++ , testProperty "mconcat" $+ \xs -> L.foldr (<>) mempty xs === mconcat (xs :: [TextLines])++ , testProperty "stimes" $+ \(Small n) xs -> stimesMonoid n xs === stimes (n :: Word) (xs :: TextLines)++ , testProperty "Position associativity" $+ \x y z -> posLine x < maxBound - posLine y && posLine y < maxBound - posLine z ==>+ (x <> y) <> z === x <> (y <> z :: Position)+ , testProperty "Position mempty <>" $+ \x -> mempty <> x === (x :: Position)+ , testProperty "Position <> mempty" $+ \x -> x <> mempty === (x :: Position)++ , testProperty "lines" $+ \x -> T.lines x === lines (fromText x)+ , testProperty "lengthInLines" $+ \x -> L.genericLength (T.lines x) === lengthInLines (fromText x)++ , testProperty "splitAtLine 1" $+ \i x -> let (y, z) = splitAtLine i x in x === y <> z+ , testProperty "splitAtLine 2" $+ \i x -> let (y, z) = splitAtLine i x in lines x === lines y <> lines z+ , testProperty "splitAtLine 3" $+ \i x -> let (y, _) = splitAtLine i x in+ L.genericLength (lines y) === min i (L.genericLength (lines x))++ , testProperty "length 1" $+ \x -> length x === utf8Length (toText x)+ , testProperty "length 2" $+ length (fromText (T.singleton '\x7f')) === 1+ , testProperty "length 3" $+ length (fromText (T.singleton '\x7ff')) === 2+ , testProperty "length 4" $+ length (fromText (T.singleton '\xffff')) === 3+ , testProperty "length 5" $+ length (fromText (T.singleton '\x10000')) === 4++ , testProperty "splitAt 1" $+ \i x -> case splitAt i x of+ Nothing -> property True+ Just (y, z) -> x === y <> z+ , testProperty "splitAt 2" $+ \i x -> case splitAt i x of+ Nothing -> property True+ Just (y, _) -> utf8Length (toText y) === min i (utf8Length (toText x))+ , testProperty "splitAt 3" $ let t = fromText (T.singleton '\x7f') in+ splitAt 1 t === Just (t, mempty)+ , testProperty "splitAt 4" $ let t = fromText (T.singleton '\x80') in+ splitAt 1 t === Nothing+ , testProperty "splitAt 5" $ let t = fromText (T.singleton '\x80') in+ splitAt 2 t === Just (t, mempty)++ , testProperty "lengthAsPosition 1" $+ \x -> splitAtPosition (lengthAsPosition x) x === Just (x, mempty)+ , testProperty "lengthAsPosition 2" $+ \x -> let Position l c = lengthAsPosition x in+ length (snd (splitAtLine l x)) === c++ , testProperty "splitAtPosition 1" $+ \i x -> case splitAtPosition i x of+ Nothing -> property True+ Just (y, z) -> x === y <> z+ , testProperty "splitAtPosition 2" $+ \i x -> case splitAtPosition i x of+ Nothing -> property True+ Just (y, z) -> lengthAsPosition x === lengthAsPosition y <> lengthAsPosition z+ , testProperty "splitAtPosition 3" $+ \i@(Position l _) x -> case splitAtPosition i x of+ Nothing -> True+ Just (y, _) ->+ let l' = min l (posLine (lengthAsPosition x)) in+ posLine (lengthAsPosition y) >= l'+ , testProperty "splitAtPosition 4" $+ \i@(Position l c) x -> case splitAtPosition i x of+ Nothing -> property True+ Just (y, z) -> null z .||. length (snd (splitAtLine l y)) === c+ , testProperty "splitAtPosition 5" $+ \i -> case splitAtPosition i mempty of+ Nothing -> property False+ Just (y, z) -> y === mempty .&&. z === mempty+ ]
+ test/Utf8Rope.hs view
@@ -0,0 +1,67 @@+module Utf8Rope+ ( testSuite+ ) where++import Prelude ((+), (-))+import Data.Bool (Bool(..))+import Data.Function (($))+import Data.Maybe (Maybe(..))+import Data.Monoid (mempty)+import Data.Semigroup ((<>))+import qualified Data.List as L+import qualified Data.Text.Utf8.Lines as Lines+import qualified Data.Text.Utf8.Rope as Rope+import Test.Tasty (testGroup, TestTree)+import Test.Tasty.QuickCheck (Positive(..), conjoin, counterexample, property, testProperty, (===), (.&&.))++import Utils ()++testSuite :: TestTree+testSuite = testGroup "Utf8 Rope"+ [ testProperty "null" $+ \x -> Rope.null x === Lines.null (Rope.toTextLines x)++ , testProperty "length" $+ \x -> Rope.length x === Lines.length (Rope.toTextLines x)++ , testProperty "lengthInLines" $+ \x -> Rope.lengthInLines x === Lines.lengthInLines (Rope.toTextLines x)++ , testProperty "lines" $+ \x -> Rope.lines x === Lines.lines (Rope.toTextLines x)++ , testProperty "splitAtLine" $+ \i x -> let (y, z) = Rope.splitAtLine i x in+ (Rope.toTextLines y, Rope.toTextLines z) === Lines.splitAtLine i (Rope.toTextLines x)++ , testProperty "splitAt 1" $+ \i x -> case Rope.splitAt i x of+ Nothing -> property True+ Just (y, z) -> x === y <> z+ , testProperty "splitAt 2" $+ \i x -> case (Rope.splitAt i x, Lines.splitAt i (Lines.fromText $ Rope.toText x)) of+ (Nothing, Nothing) -> property True+ (Nothing, Just{}) -> counterexample "can split TextLines, but not Rope" False+ (Just{}, Nothing) -> counterexample "can split Rope, but not TextLines" False+ (Just (y, z), Just (y', z')) -> Lines.fromText (Rope.toText y) === y' .&&. Lines.fromText (Rope.toText z) === z'++ , testProperty "splitAtPosition 1" $+ \i x -> case Rope.splitAtPosition i x of+ Nothing -> property True+ Just (y, z) -> x === y <> z+ , testProperty "splitAtPosition 2" $+ \i x -> case (Rope.splitAtPosition i x, Lines.splitAtPosition i (Lines.fromText $ Rope.toText x)) of+ (Nothing, Nothing) -> property True+ (Nothing, Just{}) -> counterexample "can split TextLines, but not Rope" False+ (Just{}, Nothing) -> counterexample "can split Rope, but not TextLines" False+ (Just (y, z), Just (y', z')) -> Lines.fromText (Rope.toText y) === y' .&&. Lines.fromText (Rope.toText z) === z'++ , testProperty "forall i in bounds: getLine i x == lines x !! i" $+ \x -> let lns = Rope.lines x in+ conjoin $ L.zipWith (\idx ln -> Rope.getLine idx x === Rope.fromText ln) [0..] lns+ , testProperty "forall i out of bounds: getLine i x == mempty" $+ \x (Positive offset) ->+ let maxIdx = L.genericLength (Rope.lines x) - 1+ outOfBoundsIdx = maxIdx + offset+ in Rope.getLine outOfBoundsIdx x === mempty+ ]
test/Utils.hs view
@@ -6,7 +6,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Utils- ( utf16Length+ ( utf8Length+ , utf16Length ) where import Prelude (mod, (+), (-), maxBound)@@ -14,11 +15,13 @@ import Data.Char (Char) import Data.Function (($), (.)) import qualified Data.List as L-import Data.Ord ((>))+import Data.Ord ((>), (>=)) import qualified Data.Text as T import Data.Text.Internal (Text(..)) import qualified Data.Text.Lines as Char import qualified Data.Text.Rope as CharRope+import qualified Data.Text.Utf8.Lines as Utf8+import qualified Data.Text.Utf8.Rope as Utf8Rope import qualified Data.Text.Utf16.Lines as Utf16 import qualified Data.Text.Utf16.Rope as Utf16Rope import qualified Data.Text.Utf16.Rope.Mixed as MixedRope@@ -28,6 +31,15 @@ import Data.Bool (otherwise) import Data.Maybe (maybe) +utf8Length :: Text -> Word+utf8Length t =+ L.genericLength xs ++ L.genericLength (L.filter (>= '\x0080') xs) ++ L.genericLength (L.filter (>= '\x0800') xs) ++ L.genericLength (L.filter (>= '\x10000') xs)+ where+ xs = T.unpack t+ utf16Length :: Text -> Word utf16Length t = L.genericLength xs + L.genericLength (L.filter (> '\xFFFF') xs) where@@ -67,6 +79,16 @@ shrink (Char.Position x y) = [Char.Position x' y | x' <- shrink x] L.++ [Char.Position x y' | y' <- shrink y] +instance Arbitrary Utf8.Position where+ arbitrary = oneof+ [ Utf8.Position <$> arbitrary <*> arbitrary+ , (\l -> Utf8.Position (maxBound - l)) <$> arbitrary <*> arbitrary+ , (\l c -> Utf8.Position l (maxBound - c)) <$> arbitrary <*> arbitrary+ , (\l c -> Utf8.Position (maxBound - l) (maxBound - c)) <$> arbitrary <*> arbitrary+ ]+ shrink (Utf8.Position x y) =+ [Utf8.Position x' y | x' <- shrink x] L.++ [Utf8.Position x y' | y' <- shrink y]+ instance Arbitrary Utf16.Position where arbitrary = oneof [ Utf16.Position <$> arbitrary <*> arbitrary@@ -86,6 +108,16 @@ | CharRope.null rp = [] | otherwise = L.concatMap (\i -> (\(x, y) -> [x, y]) (CharRope.splitAt i rp)) [1..CharRope.length rp - 1]++instance Arbitrary Utf8Rope.Rope where+ arbitrary = frequency+ [ (9, mconcat . L.map Utf8Rope.fromText <$> arbitrary)+ , (1, mappend <$> arbitrary <*> arbitrary)+ ]+ shrink rp+ | Utf8Rope.null rp = []+ | otherwise = L.concatMap (\i -> maybe [] (\(x, y) -> [x, y]) (Utf8Rope.splitAt i rp))+ [1..Utf8Rope.length rp - 1] instance Arbitrary Utf16Rope.Rope where arbitrary = frequency
text-rope.cabal view
@@ -1,24 +1,25 @@ name: text-rope-version: 0.2+version: 0.3 cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE-copyright: 2021-2022 Andrew Lelechenko+copyright: 2021-2022 Andrew Lelechenko, 2024 Olle Fredriksson maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> homepage: https://github.com/Bodigrim/text-rope category: Text synopsis: Text lines and ropes description: A wrapper around `Text` for fast line/column navigation and logarithmic concatenation.-author: Andrew Lelechenko <andrew.lelechenko@gmail.com>+author: Andrew Lelechenko <andrew.lelechenko@gmail.com>, Olle Fredriksson <fredriksson.olle@gmail.com> extra-source-files: changelog.md README.md data-files: bench/bench.txt+ bench/bench-utf8.txt -tested-with: GHC == 9.2.2, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2+tested-with: GHC == 9.10.1, GHC == 9.8.2, GHC == 9.6.5, GHC == 9.4.8, GHC == 9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 source-repository head type: git@@ -33,16 +34,19 @@ exposed-modules: Data.Text.Lines Data.Text.Rope+ Data.Text.Utf8.Lines Data.Text.Utf16.Lines+ Data.Text.Utf8.Rope Data.Text.Utf16.Rope Data.Text.Utf16.Rope.Mixed+ Data.Text.Mixed.Rope other-modules: Data.Text.Lines.Internal build-depends: base >=4.9 && <5,- deepseq,- text >= 1.2.3,- vector >=0.11+ deepseq < 1.6,+ text >= 1.2.3 && < 2.2,+ vector >=0.11 && < 0.14 default-language: Haskell2010 hs-source-dirs: src ghc-options: -O2 -Wall -Wcompat -fexpose-all-unfoldings@@ -60,6 +64,8 @@ CharLines CharRope MixedRope+ Utf8Lines+ Utf8Rope Utf16Lines Utf16Rope Utils@@ -67,7 +73,7 @@ base, text-rope, tasty,- tasty-quickcheck,+ tasty-quickcheck >= 0.8.1, text default-language: Haskell2010 hs-source-dirs: test@@ -87,6 +93,7 @@ random, -- yi-rope, -- rope-utf16-splay,+ tasty >= 1.2, tasty-bench >= 0.3, text default-language: Haskell2010