streamly 0.7.1 → 0.7.2
raw patch · 85 files changed
+10993/−7106 lines, 85 filesdep +unliftio-coredep −bench-showdep −gaugedep −splitdep ~QuickCheckdep ~ghc-primdep ~random
Dependencies added: unliftio-core
Dependencies removed: bench-show, gauge, split, typed-process
Dependency ranges changed: QuickCheck, ghc-prim, random, template-haskell
Files
- Changelog.md +16/−0
- bench.sh +62/−8
- benchmark/Adaptive.hs +0/−132
- benchmark/Array.hs +0/−251
- benchmark/ArrayOps.hs +0/−531
- benchmark/BaseStreams.hs +0/−380
- benchmark/Chart.hs +50/−71
- benchmark/Common.hs +0/−95
- benchmark/Concurrent.hs +0/−103
- benchmark/FileIO.hs +9/−0
- benchmark/Linear.hs +0/−575
- benchmark/LinearAsync.hs +0/−147
- benchmark/LinearRate.hs +0/−68
- benchmark/Nested.hs +0/−61
- benchmark/NestedConcurrent.hs +0/−84
- benchmark/NestedOps.hs +0/−174
- benchmark/NestedUnfold.hs +0/−38
- benchmark/NestedUnfoldOps.hs +0/−126
- benchmark/Parallel.hs +0/−93
- benchmark/README.md +102/−0
- benchmark/StreamDKOps.hs +0/−423
- benchmark/StreamDOps.hs +0/−357
- benchmark/StreamKOps.hs +0/−410
- benchmark/Streamly/Benchmark/Data/Fold.hs +230/−0
- benchmark/Streamly/Benchmark/Data/NestedUnfoldOps.hs +126/−0
- benchmark/Streamly/Benchmark/Data/Parser.hs +215/−0
- benchmark/Streamly/Benchmark/Data/Stream/BaseStreams.hs +40/−0
- benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs +541/−0
- benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs +452/−0
- benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs +609/−0
- benchmark/Streamly/Benchmark/Data/Unfold.hs +77/−0
- benchmark/Streamly/Benchmark/FileIO/Stream.hs +16/−1
- benchmark/Streamly/Benchmark/Memory/Array.hs +251/−0
- benchmark/Streamly/Benchmark/Memory/ArrayOps.hs +531/−0
- benchmark/Streamly/Benchmark/Prelude.hs +0/−1202
- benchmark/Streamly/Benchmark/Prelude/Adaptive.hs +132/−0
- benchmark/Streamly/Benchmark/Prelude/Concurrent.hs +103/−0
- benchmark/Streamly/Benchmark/Prelude/LinearAsync.hs +46/−0
- benchmark/Streamly/Benchmark/Prelude/LinearRate.hs +24/−0
- benchmark/Streamly/Benchmark/Prelude/NestedConcurrent.hs +84/−0
- benchmark/Streamly/Benchmark/Prelude/NestedOps.hs +174/−0
- benchmark/Streamly/Benchmark/Prelude/Parallel.hs +35/−0
- benchmark/Streamly/Benchmark/Prelude/Serial/O_1_Space.hs +59/−0
- benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Heap.hs +30/−0
- benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Space.hs +31/−0
- benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Stack.hs +26/−0
- benchmark/lib/Streamly/Benchmark/Common.hs +196/−0
- benchmark/lib/Streamly/Benchmark/Prelude.hs +2700/−0
- benchmark/streamly-benchmarks.cabal +473/−0
- configure +23/−10
- configure.ac +1/−1
- credits/CONTRIBUTORS.md +9/−0
- docs/Build.md +7/−3
- examples/EchoServer.hs +12/−9
- examples/WordClassifier.hs +3/−3
- src/Streamly/FileSystem/IOVec.hsc +11/−2
- src/Streamly/Internal/Data/Fold.hs +270/−18
- src/Streamly/Internal/Data/Fold/Types.hs +135/−19
- src/Streamly/Internal/Data/Parser.hs +869/−0
- src/Streamly/Internal/Data/Parser/Tee.hs +529/−0
- src/Streamly/Internal/Data/Parser/Types.hs +634/−0
- src/Streamly/Internal/Data/Prim/Array/Types.hs +4/−735
- src/Streamly/Internal/Data/Stream/Combinators.hs +3/−0
- src/Streamly/Internal/Data/Stream/Parallel.hs +3/−3
- src/Streamly/Internal/Data/Stream/Prelude.hs +14/−0
- src/Streamly/Internal/Data/Stream/SVar.hs +4/−0
- src/Streamly/Internal/Data/Stream/StreamD.hs +232/−21
- src/Streamly/Internal/Data/Stream/StreamK.hs +2/−0
- src/Streamly/Internal/Data/Stream/StreamK/Type.hs +2/−1
- src/Streamly/Internal/Data/Time/Clock.hsc +6/−3
- src/Streamly/Internal/Data/Time/config.h.in +1/−1
- src/Streamly/Internal/Data/Unfold.hs +130/−12
- src/Streamly/Internal/Data/Unicode/Char.hs +17/−0
- src/Streamly/Internal/FileSystem/Dir.hs +0/−4
- src/Streamly/Internal/FileSystem/File.hs +5/−9
- src/Streamly/Internal/FileSystem/Handle.hs +1/−4
- src/Streamly/Internal/Memory/Array.hs +7/−7
- src/Streamly/Internal/Memory/Array/Types.hs +20/−22
- src/Streamly/Internal/Memory/ArrayStream.hs +0/−3
- src/Streamly/Internal/Prelude.hs +453/−371
- src/Streamly/Network/Socket.hs +68/−8
- src/Streamly/Prelude.hs +0/−138
- streamly.cabal +32/−355
- test/Main.hs +33/−13
- test/Streamly/Test/Array.hs +13/−1
Changelog.md view
@@ -1,3 +1,19 @@+## 0.7.2++### Bug Fixes++* Fix a bug in the `Applicative` and `Functor` instances of the `Fold`+ data type.++### Build Issues++* Fix a bug that occasionally caused a build failure on windows when+ used with `stack` or `stack ghci`.+* Now builds on 32-bit machines.+* Now builds with `primitive` package version >= 0.5.4 && <= 0.6.4.0+* Now builds with newer `QuickCheck` package version >= 2.14 && < 2.15.+* Now builds with GHC 8.10.+ ## 0.7.1 ### Bug Fixes
bench.sh view
@@ -1,19 +1,61 @@ #!/bin/bash -SERIAL_BENCHMARKS="linear linear-rate nested nested-unfold base"+SERIAL_O_1="linear base"+SERIAL_O_n="serial-o-n-heap serial-o-n-stack serial-o-n-space \+ base-o-n-heap base-o-n-stack base-o-n-space"+FOLD_BENCHMARKS="fold-o-1-space fold-o-n-heap"+UNFOLD_BENCHMARKS="unfold-o-1-space unfold-o-n-space"++SERIAL_BENCHMARKS="$SERIAL_O_1 $SERIAL_O_n $FOLD_BENCHMARKS" # parallel benchmark-suite is separated because we run it with a higher # heap size limit.-CONCURRENT_BENCHMARKS="linear-async nested-concurrent parallel concurrent adaptive"+CONCURRENT_BENCHMARKS="linear-async linear-rate nested-concurrent parallel concurrent adaptive" ARRAY_BENCHMARKS="array unpinned-array prim-array small-array" -INFINITE_BENCHMARKS="$SERIAL_BENCHMARKS linear-async nested-concurrent"-FINITE_BENCHMARKS="$ARRAY_BENCHMARKS fileio parallel concurrent adaptive"+# XXX We can include SERIAL_O_1 here once "base" also supports --stream-size+INFINITE_BENCHMARKS="linear linear-async linear-rate nested-concurrent"+FINITE_BENCHMARKS="$SERIAL_O_n $ARRAY_BENCHMARKS fileio parallel concurrent adaptive" -QUICK_BENCHMARKS="linear-rate concurrent adaptive"+# Benchmarks that take long time per iteration must run fewer iterations to+# finish in reasonable time.+QUICK_BENCHMARKS="linear-rate concurrent adaptive fileio" VIRTUAL_BENCHMARKS="array-cmp" ALL_BENCHMARKS="$SERIAL_BENCHMARKS $CONCURRENT_BENCHMARKS $ARRAY_BENCHMARKS $VIRTUAL_BENCHMARKS" +# RTS options that go inside +RTS and -RTS while running the benchmark.+bench_rts_opts () {+ case "$1" in+ "fold-o-1-space") echo -n "-T -K36K -M16M" ;;+ "fold-o-n-heap") echo -n "-T -K36K -M128M" ;;+ "unfold-o-1-space") echo -n "-T -K36K -M16M" ;;+ "unfold-o-n-space") echo -n "-T -K32M -M64M" ;;+ *) echo -n "" ;;+ esac+}++# The correct executable for the given benchmark name.+bench_exec () {+ case "$1" in+ "fold-o-1-space") echo -n "fold" ;;+ "fold-o-n-heap") echo -n "fold" ;;+ "unfold-o-1-space") echo -n "unfold" ;;+ "unfold-o-n-space") echo -n "unfold" ;;+ *) echo -n "$1" ;;+ esac+}++# Specific gauge options for the given benchmark.+bench_gauge_opts () {+ case "$1" in+ "fold-o-1-space") echo -n "-m prefix o-1-space" ;;+ "fold-o-n-heap") echo -n "-m prefix o-n-heap" ;;+ "unfold-o-1-space") echo -n "-m prefix o-1-space" ;;+ "unfold-o-n-space") echo -n "-m prefix o-n-space" ;;+ *) echo -n "" ;;+ esac+}+ list_benches () { for i in $ALL_BENCHMARKS do@@ -170,10 +212,11 @@ run_bench () { local bench_name=$1+ local bench_exe=$(bench_exec $bench_name) local output_file=$(bench_output_file $bench_name) local bench_prog local quick_bench=0- bench_prog=$($GET_BENCH_PROG $bench_name) || \+ bench_prog=$($GET_BENCH_PROG $bench_exe) || \ die "Cannot find benchmark executable for benchmark $bench_name" mkdir -p `dirname $output_file`@@ -210,9 +253,11 @@ fi $bench_prog $SPEED_OPTIONS \+ +RTS $(bench_rts_opts $bench_name) -RTS \ --csvraw=$output_file \ -v 2 \- --measure-with $bench_prog $GAUGE_ARGS || die "Benchmarking failed"+ --measure-with $bench_prog $GAUGE_ARGS \+ $(bench_gauge_opts $bench_name) || die "Benchmarking failed" } run_benches() {@@ -375,8 +420,17 @@ done } +proper_executables () {+ for i in $BENCHMARKS+ do+ echo -n "$(bench_exec $i) "+ done+}++ BENCHMARKS_ORIG=$BENCHMARKS BENCHMARKS=$(only_real_benchmarks)+EXECUTABLES=$(proper_executables) echo "Using benchmark suites [$BENCHMARKS]" has_benchmark () {@@ -424,7 +478,7 @@ then $BUILD_BENCH || die "build failed" else- $BUILD_BENCH $BENCHMARKS || die "build failed"+ $BUILD_BENCH $EXECUTABLES || die "build failed" fi run_measurements "$BENCHMARKS" fi
− benchmark/Adaptive.hs
@@ -1,132 +0,0 @@--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.Concurrent (threadDelay)-import Control.Monad (when)-import Control.Monad.IO.Class (liftIO)-import Gauge-import Streamly-import Streamly.Prelude as S-import System.Random (randomRIO)---- Note that we should also compare the cpuTime especially when threaded--- runtime is used with this benchmark because thread scheduling is not--- predictable and can add non-deterministic delay to the total time measured.------ Also, the worker dispatch depends on the worker dispatch latency which is--- set to fixed 200 us. We need to keep that in mind when designing tests.--value :: Int-value = 1000--{-# INLINE source #-}-source :: IsStream t => (Int, Int) -> t IO Int-source range = S.replicateM value $ do- r <- randomRIO range- when (r /= 0) $ liftIO $ threadDelay r- return r--{-# INLINE run #-}-run :: IsStream t => (Int, Int) -> (Int, Int) -> (t IO Int -> SerialT IO Int) -> IO ()-run srange crange t = S.drain $ do- n <- t $ source srange- d <- liftIO (randomRIO crange)- when (d /= 0) $ liftIO $ threadDelay d- return n--low, medium, high :: Int-low = 10-medium = 20-high = 30--{-# INLINE noDelay #-}-noDelay :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-noDelay = run (0,0) (0,0)--{-# INLINE alwaysConstSlowSerial #-}-alwaysConstSlowSerial :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-alwaysConstSlowSerial = run (0,0) (medium,medium)--{-# INLINE alwaysConstSlow #-}-alwaysConstSlow :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-alwaysConstSlow = run (low,low) (medium,medium)--{-# INLINE alwaysConstFast #-}-alwaysConstFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-alwaysConstFast = run (high,high) (medium,medium)--{-# INLINE alwaysVarSlow #-}-alwaysVarSlow :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-alwaysVarSlow = run (low,low) (low,high)--{-# INLINE alwaysVarFast #-}-alwaysVarFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-alwaysVarFast = run (high,high) (low,high)---- XXX add variable producer tests as well--{-# INLINE runVarSometimesFast #-}-runVarSometimesFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-runVarSometimesFast = run (medium,medium) (low,high)--{-# INLINE randomVar #-}-randomVar :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()-randomVar = run (low,high) (low,high)--main :: IO ()-main =- defaultMain- [- bgroup "serialConstantSlowConsumer"- [ bench "serially" $ nfIO $ alwaysConstSlowSerial serially- , bench "wSerially" $ nfIO $ alwaysConstSlowSerial wSerially- ]- , bgroup "default"- [ bench "serially" $ nfIO $ noDelay serially- , bench "wSerially" $ nfIO $ noDelay wSerially- , bench "aheadly" $ nfIO $ noDelay aheadly- , bench "asyncly" $ nfIO $ noDelay asyncly- , bench "wAsyncly" $ nfIO $ noDelay wAsyncly- , bench "parallely" $ nfIO $ noDelay parallely- ]- , bgroup "constantSlowConsumer"- [ bench "aheadly" $ nfIO $ alwaysConstSlow aheadly- , bench "asyncly" $ nfIO $ alwaysConstSlow asyncly- , bench "wAsyncly" $ nfIO $ alwaysConstSlow wAsyncly- , bench "parallely" $ nfIO $ alwaysConstSlow parallely- ]- , bgroup "constantFastConsumer"- [ bench "aheadly" $ nfIO $ alwaysConstFast aheadly- , bench "asyncly" $ nfIO $ alwaysConstFast asyncly- , bench "wAsyncly" $ nfIO $ alwaysConstFast wAsyncly- , bench "parallely" $ nfIO $ alwaysConstFast parallely- ]- , bgroup "variableSlowConsumer"- [ bench "aheadly" $ nfIO $ alwaysVarSlow aheadly- , bench "asyncly" $ nfIO $ alwaysVarSlow asyncly- , bench "wAsyncly" $ nfIO $ alwaysVarSlow wAsyncly- , bench "parallely" $ nfIO $ alwaysVarSlow parallely- ]- , bgroup "variableFastConsumer"- [ bench "aheadly" $ nfIO $ alwaysVarFast aheadly- , bench "asyncly" $ nfIO $ alwaysVarFast asyncly- , bench "wAsyncly" $ nfIO $ alwaysVarFast wAsyncly- , bench "parallely" $ nfIO $ alwaysVarFast parallely- ]- , bgroup "variableSometimesFastConsumer"- [ bench "aheadly" $ nfIO $ runVarSometimesFast aheadly- , bench "asyncly" $ nfIO $ runVarSometimesFast asyncly- , bench "wAsyncly" $ nfIO $ runVarSometimesFast wAsyncly- , bench "parallely" $ nfIO $ runVarSometimesFast parallely- ]- , bgroup "variableFullOverlap"- [ bench "aheadly" $ nfIO $ randomVar aheadly- , bench "asyncly" $ nfIO $ randomVar asyncly- , bench "wAsyncly" $ nfIO $ randomVar wAsyncly- , bench "parallely" $ nfIO $ randomVar parallely- ]- ]
− benchmark/Array.hs
@@ -1,251 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.DeepSeq (NFData(..), deepseq)-import Foreign.Storable (Storable(..))-import System.Random (randomRIO)--import qualified GHC.Exts as GHC--import qualified ArrayOps as Ops-import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S--import Gauge----------------------------------------------------------------------------------------------------------------------------------------------------------------------{-# INLINE benchPure #-}-benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark-benchPure name src f = bench name $ nfIO $- randomRIO (1,1) >>= return . f . src---- Drain a source that generates a pure array-{-# INLINE benchPureSrc #-}-benchPureSrc :: (NFData a, Storable a)- => String -> (Int -> Ops.Stream a) -> Benchmark-benchPureSrc name src = benchPure name src id--{-# INLINE benchIO #-}-benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark-benchIO name src f = bench name $ nfIO $- randomRIO (1,1) >>= src >>= return . f---- Drain a source that generates an array in the IO monad-{-# INLINE benchIOSrc #-}-benchIOSrc :: (NFData a, Storable a)- => String -> (Int -> IO (Ops.Stream a)) -> Benchmark-benchIOSrc name src = benchIO name src id--{-# INLINE benchPureSink #-}-benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark-benchPureSink name f = benchIO name Ops.sourceIntFromTo f--{-# INLINE benchIO' #-}-benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark-benchIO' name src f = bench name $ nfIO $- randomRIO (1,1) >>= src >>= f--{-# INLINE benchIOSink #-}-benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark-benchIOSink name f = benchIO' name Ops.sourceIntFromTo f--mkString :: String-mkString = "[1" ++ concat (replicate Ops.value ",1") ++ "]"--main :: IO ()-main =- defaultMain- [ bgroup "array"- [ bgroup "generation"- [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo- , benchIOSrc "write . intFromTo" Ops.sourceIntFromToFromStream- , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList- , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr- , benchIOSrc "writeN . fromList" Ops.sourceFromList- , benchPureSrc "writeN . IsList.fromList" Ops.sourceIsList- , benchPureSrc "writeN . IsString.fromString" Ops.sourceIsString- , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString)- , benchPureSink "show" Ops.showInstance- ]- , bgroup "elimination"- [ benchPureSink "id" id- -- , benchPureSink "eqBy" Ops.eqBy- , benchPureSink "==" Ops.eqInstance- , benchPureSink "/=" Ops.eqInstanceNotEq- {-- , benchPureSink "cmpBy" Ops.cmpBy- -}- , benchPureSink "<" Ops.ordInstance- , benchPureSink "min" Ops.ordInstanceMin- -- length is used to check for foldr/build fusion- , benchPureSink "length . IsList.toList" (length . GHC.toList)- , benchIOSink "foldl'" Ops.pureFoldl'- , benchIOSink "read" (S.drain . S.unfold A.read)- , benchIOSink "toStreamRev" (S.drain . IA.toStreamRev)-#ifdef DEVBUILD- , benchPureSink "foldable/foldl'" Ops.foldableFoldl'- , benchPureSink "foldable/sum" Ops.foldableSum- -- , benchPureSinkIO "traversable/mapM" Ops.traversableMapM-#endif- ]-- {-- [ benchPureSink "uncons" Ops.uncons- , benchPureSink "toNull" $ Ops.toNull serially- , benchPureSink "mapM_" Ops.mapM_-- , benchPureSink "init" Ops.init- , benchPureSink "tail" Ops.tail- , benchPureSink "nullHeadTail" Ops.nullHeadTail-- -- this is too low and causes all benchmarks reported in ns- -- , benchPureSink "head" Ops.head- , benchPureSink "last" Ops.last- -- , benchPureSink "lookup" Ops.lookup- , benchPureSink "find" Ops.find- , benchPureSink "findIndex" Ops.findIndex- , benchPureSink "elemIndex" Ops.elemIndex-- -- this is too low and causes all benchmarks reported in ns- -- , benchPureSink "null" Ops.null- , benchPureSink "elem" Ops.elem- , benchPureSink "notElem" Ops.notElem- , benchPureSink "all" Ops.all- , benchPureSink "any" Ops.any- , benchPureSink "and" Ops.and- , benchPureSink "or" Ops.or-- , benchPureSink "length" Ops.length- , benchPureSink "sum" Ops.sum- , benchPureSink "product" Ops.product-- , benchPureSink "maximumBy" Ops.maximumBy- , benchPureSink "maximum" Ops.maximum- , benchPureSink "minimumBy" Ops.minimumBy- , benchPureSink "minimum" Ops.minimum-- , benchPureSink "toList" Ops.toList- , benchPureSink "toRevList" Ops.toRevList- ]- -}- , bgroup "transformation"- [ benchIOSink "scanl'" (Ops.scanl' 1)- , benchIOSink "scanl1'" (Ops.scanl1' 1)- , benchIOSink "map" (Ops.map 1)- {-- , benchPureSink "fmap" (Ops.fmap 1)- , benchPureSink "mapM" (Ops.mapM serially 1)- , benchPureSink "mapMaybe" (Ops.mapMaybe 1)- , benchPureSink "mapMaybeM" (Ops.mapMaybeM 1)- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->- Ops.sequence serially (Ops.sourceUnfoldrMAction n)- , benchPureSink "findIndices" (Ops.findIndices 1)- , benchPureSink "elemIndices" (Ops.elemIndices 1)- , benchPureSink "reverse" (Ops.reverse 1)- , benchPureSink "foldrS" (Ops.foldrS 1)- , benchPureSink "foldrSMap" (Ops.foldrSMap 1)- , benchPureSink "foldrT" (Ops.foldrT 1)- , benchPureSink "foldrTMap" (Ops.foldrTMap 1)- -}- ]- , bgroup "transformationX4"- [ benchIOSink "scanl'" (Ops.scanl' 4)- , benchIOSink "scanl1'" (Ops.scanl1' 4)- , benchIOSink "map" (Ops.map 4)- {-- , benchPureSink "fmap" (Ops.fmap 4)- , benchPureSink "mapM" (Ops.mapM serially 4)- , benchPureSink "mapMaybe" (Ops.mapMaybe 4)- , benchPureSink "mapMaybeM" (Ops.mapMaybeM 4)- -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->- -- Ops.sequence serially (Ops.sourceUnfoldrMAction n)- , benchPureSink "findIndices" (Ops.findIndices 4)- , benchPureSink "elemIndices" (Ops.elemIndices 4)- -}- ]- {-- , bgroup "filtering"- [ benchPureSink "filter-even" (Ops.filterEven 1)- , benchPureSink "filter-all-out" (Ops.filterAllOut 1)- , benchPureSink "filter-all-in" (Ops.filterAllIn 1)- , benchPureSink "take-all" (Ops.takeAll 1)- , benchPureSink "takeWhile-true" (Ops.takeWhileTrue 1)- --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 1)- , benchPureSink "drop-one" (Ops.dropOne 1)- , benchPureSink "drop-all" (Ops.dropAll 1)- , benchPureSink "dropWhile-true" (Ops.dropWhileTrue 1)- --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 1)- , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 1)- , benchPureSink "deleteBy" (Ops.deleteBy 1)- , benchPureSink "insertBy" (Ops.insertBy 1)- ]- , bgroup "filteringX4"- [ benchPureSink "filter-even" (Ops.filterEven 4)- , benchPureSink "filter-all-out" (Ops.filterAllOut 4)- , benchPureSink "filter-all-in" (Ops.filterAllIn 4)- , benchPureSink "take-all" (Ops.takeAll 4)- , benchPureSink "takeWhile-true" (Ops.takeWhileTrue 4)- --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 4)- , benchPureSink "drop-one" (Ops.dropOne 4)- , benchPureSink "drop-all" (Ops.dropAll 4)- , benchPureSink "dropWhile-true" (Ops.dropWhileTrue 4)- --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 4)- , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 4)- , benchPureSink "deleteBy" (Ops.deleteBy 4)- , benchPureSink "insertBy" (Ops.insertBy 4)- ]- , bgroup "multi-stream"- [ benchPureSink "eqBy" Ops.eqBy- , benchPureSink "cmpBy" Ops.cmpBy- , benchPureSink "zip" Ops.zip- , benchPureSink "zipM" Ops.zipM- , benchPureSink "mergeBy" Ops.mergeBy- , benchPureSink "isPrefixOf" Ops.isPrefixOf- , benchPureSink "isSubsequenceOf" Ops.isSubsequenceOf- , benchPureSink "stripPrefix" Ops.stripPrefix- , benchPureSrc serially "concatMap" Ops.concatMap- ]- -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl- -- library. If scan/fold followed by a map is efficient enough we may not- -- need monolithic implementations of these.- , bgroup "mixed"- [ benchPureSink "scanl-map" (Ops.scanMap 1)- , benchPureSink "foldl-map" Ops.foldl'ReduceMap- , benchPureSink "sum-product-fold" Ops.sumProductFold- , benchPureSink "sum-product-scan" Ops.sumProductScan- ]- , bgroup "mixedX4"- [ benchPureSink "scan-map" (Ops.scanMap 4)- , benchPureSink "drop-map" (Ops.dropMap 4)- , benchPureSink "drop-scan" (Ops.dropScan 4)- , benchPureSink "take-drop" (Ops.takeDrop 4)- , benchPureSink "take-scan" (Ops.takeScan 4)- , benchPureSink "take-map" (Ops.takeMap 4)- , benchPureSink "filter-drop" (Ops.filterDrop 4)- , benchPureSink "filter-take" (Ops.filterTake 4)- , benchPureSink "filter-scan" (Ops.filterScan 4)- , benchPureSink "filter-scanl1" (Ops.filterScanl1 4)- , benchPureSink "filter-map" (Ops.filterMap 4)- ]- , bgroup "iterated"- [ benchPureSrc serially "mapM" Ops.iterateMapM- , benchPureSrc serially "scan(1/100)" Ops.iterateScan- , benchPureSrc serially "scanl1(1/100)" Ops.iterateScanl1- , benchPureSrc serially "filterEven" Ops.iterateFilterEven- , benchPureSrc serially "takeAll" Ops.iterateTakeAll- , benchPureSrc serially "dropOne" Ops.iterateDropOne- , benchPureSrc serially "dropWhileFalse" Ops.iterateDropWhileFalse- , benchPureSrc serially "dropWhileTrue" Ops.iterateDropWhileTrue- ]- -}- ]- ]
− benchmark/ArrayOps.hs
@@ -1,531 +0,0 @@--- |--- Module : ArrayOps--- Copyright : (c) 2018 Harendra Kumar------ License : MIT--- Maintainer : streamly@composewell.com--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}--module ArrayOps where---- import Control.Monad (when)-import Control.Monad.IO.Class (MonadIO)--- import Data.Maybe (fromJust)-import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined)-import qualified Prelude as P-#ifdef DEVBUILD-import qualified Data.Foldable as F-#endif-import qualified GHC.Exts as GHC--- import Control.DeepSeq (NFData)--- import GHC.Generics (Generic)--import qualified Streamly as S hiding (foldMapWith, runStream)-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S--value, maxValue :: Int-#ifdef LINEAR_ASYNC-value = 10000-#else-value = 100000-#endif-maxValue = value + 1------------------------------------------------------------------------------------ Benchmark ops-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Stream generation and elimination----------------------------------------------------------------------------------type Stream = A.Array--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: MonadIO m => Int -> m (Stream Int)-sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n- where- step cnt =- if cnt > n + value- then Nothing- else (Just (cnt, cnt + 1))--{-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: MonadIO m => Int -> m (Stream Int)-sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value)--{-# INLINE sourceIntFromToFromStream #-}-sourceIntFromToFromStream :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromStream n = S.fold A.write $ S.enumerateFromTo n (n + value)--sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromList n = P.return $ A.fromList $ [n..n + value]--{-# INLINE sourceFromList #-}-sourceFromList :: MonadIO m => Int -> m (Stream Int)-sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value]--{-# INLINE sourceIsList #-}-sourceIsList :: Int -> Stream Int-sourceIsList n = GHC.fromList [n..n+value]--{-# INLINE sourceIsString #-}-sourceIsString :: Int -> Stream P.Char-sourceIsString n = GHC.fromString (P.replicate (n + value) 'a')--{------------------------------------------------------------------------------------ Elimination----------------------------------------------------------------------------------{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.runStream--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]--{-# INLINE head #-}-{-# INLINE last #-}-{-# INLINE maximum #-}-{-# INLINE minimum #-}-{-# INLINE find #-}-{-# INLINE findIndex #-}-{-# INLINE elemIndex #-}-{-# INLINE foldl1'Reduce #-}-head, last, minimum, maximum, find, findIndex, elemIndex, foldl1'Reduce- :: Monad m => Stream m Int -> m (Maybe Int)--{-# INLINE minimumBy #-}-{-# INLINE maximumBy #-}-minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int)--{-# INLINE foldl'Reduce #-}-{-# INLINE foldl'ReduceMap #-}-{-# INLINE foldlM'Reduce #-}-{-# INLINE foldrMReduce #-}-{-# INLINE length #-}-{-# INLINE sum #-}-{-# INLINE product #-}-foldl'Reduce, foldl'ReduceMap, foldlM'Reduce, foldrMReduce, length, sum, product- :: Monad m- => Stream m Int -> m Int--{-# INLINE foldl'Build #-}-{-# INLINE foldlM'Build #-}-{-# INLINE foldrMBuild #-}-foldrMBuild, foldl'Build, foldlM'Build- :: Monad m- => Stream m Int -> m [Int]--{-# INLINE all #-}-{-# INLINE any #-}-{-# INLINE and #-}-{-# INLINE or #-}-{-# INLINE null #-}-{-# INLINE elem #-}-{-# INLINE notElem #-}-null, elem, notElem, all, any, and, or :: Monad m => Stream m Int -> m Bool--{-# INLINE toNull #-}-toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()-toNull t = runStream . t--{-# INLINE uncons #-}-uncons :: Monad m => Stream m Int -> m ()-uncons s = do- r <- S.uncons s- case r of- Nothing -> return ()- Just (_, t) -> uncons t--{-# INLINE init #-}-init :: Monad m => Stream m a -> m ()-init s = S.init s >>= Prelude.mapM_ S.runStream--{-# INLINE tail #-}-tail :: Monad m => Stream m a -> m ()-tail s = S.tail s >>= Prelude.mapM_ tail--{-# INLINE nullHeadTail #-}-nullHeadTail :: Monad m => Stream m Int -> m ()-nullHeadTail s = do- r <- S.null s- when (not r) $ do- _ <- S.head s- S.tail s >>= Prelude.mapM_ nullHeadTail--{-# INLINE mapM_ #-}-mapM_ :: Monad m => Stream m Int -> m ()-mapM_ = S.mapM_ (\_ -> return ())--toList = S.toList--{-# INLINE toRevList #-}-toRevList :: Monad m => Stream m Int -> m [Int]-toRevList = S.toRevList--foldrMBuild = S.foldrM (\x xs -> xs >>= return . (x :)) (return [])-foldl'Build = S.foldl' (flip (:)) []-foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []--foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0)-foldl'Reduce = S.foldl' (+) 0-foldl'ReduceMap = P.fmap (+1) . S.foldl' (+) 0-foldl1'Reduce = S.foldl1' (+)-foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0--last = S.last-null = S.null-head = S.head-elem = S.elem maxValue-notElem = S.notElem maxValue-length = S.length-all = S.all (<= maxValue)-any = S.any (> maxValue)-and = S.and . S.map (<= maxValue)-or = S.or . S.map (> maxValue)-find = S.find (== maxValue)-findIndex = S.findIndex (== maxValue)-elemIndex = S.elemIndex maxValue-maximum = S.maximum-minimum = S.minimum-sum = S.sum-product = S.product-minimumBy = S.minimumBy compare-maximumBy = S.maximumBy compare--}------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{--{-# INLINE transform #-}-transform :: Stream a -> Stream a-transform = P.id--}--{-# INLINE composeN #-}-composeN :: P.Monad m- => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int)-composeN n f x =- case n of- 1 -> f x- 2 -> f x P.>>= f- 3 -> f x P.>>= f P.>>= f- 4 -> f x P.>>= f P.>>= f P.>>= f- _ -> undefined--{-# INLINE scanl' #-}-{-# INLINE scanl1' #-}-{-# INLINE map #-}-{--{-# INLINE fmap #-}-{-# INLINE mapMaybe #-}-{-# INLINE filterEven #-}-{-# INLINE filterAllOut #-}-{-# INLINE filterAllIn #-}-{-# INLINE takeOne #-}-{-# INLINE takeAll #-}-{-# INLINE takeWhileTrue #-}-{-# INLINE takeWhileMTrue #-}-{-# INLINE dropOne #-}-{-# INLINE dropAll #-}-{-# INLINE dropWhileTrue #-}-{-# INLINE dropWhileMTrue #-}-{-# INLINE dropWhileFalse #-}-{-# INLINE findIndices #-}-{-# INLINE elemIndices #-}-{-# INLINE insertBy #-}-{-# INLINE deleteBy #-}-{-# INLINE reverse #-}-{-# INLINE foldrS #-}-{-# INLINE foldrSMap #-}-{-# INLINE foldrT #-}-{-# INLINE foldrTMap #-}- -}-scanl' , scanl1', map{-, fmap, mapMaybe, filterEven, filterAllOut,- filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,- dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse,- findIndices, elemIndices, insertBy, deleteBy, reverse,- foldrS, foldrSMap, foldrT, foldrTMap -}- :: MonadIO m => Int -> Stream Int -> m (Stream Int)--{--{-# INLINE mapMaybeM #-}-mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m ()--{-# INLINE mapM #-}-{-# INLINE map' #-}-{-# INLINE fmap' #-}-mapM, map' :: (S.IsStream t, S.MonadAsync m)- => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()--fmap' :: (S.IsStream t, S.MonadAsync m, P.Functor (t m))- => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()--{-# INLINE sequence #-}-sequence :: (S.IsStream t, S.MonadAsync m)- => (t m Int -> S.SerialT m Int) -> t m (m Int) -> m ()- -}--{-# INLINE onArray #-}-onArray- :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int)- -> Stream Int- -> m (Stream Int)-onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr)--scanl' n = composeN n $ onArray $ S.scanl' (+) 0-scanl1' n = composeN n $ onArray $ S.scanl1' (+)-map n = composeN n $ onArray $ S.map (+1)--- map n = composeN n $ A.map (+1)-{--fmap n = composeN n $ Prelude.fmap (+1)-fmap' t n = composeN' n $ t . Prelude.fmap (+1)-map' t n = composeN' n $ t . S.map (+1)-mapM t n = composeN' n $ t . S.mapM return-mapMaybe n = composeN n $ S.mapMaybe- (\x -> if Prelude.odd x then Nothing else Just x)-mapMaybeM n = composeN n $ S.mapMaybeM- (\x -> if Prelude.odd x then return Nothing else return $ Just x)-sequence t = transform . t . S.sequence-filterEven n = composeN n $ S.filter even-filterAllOut n = composeN n $ S.filter (> maxValue)-filterAllIn n = composeN n $ S.filter (<= maxValue)-takeOne n = composeN n $ S.take 1-takeAll n = composeN n $ S.take maxValue-takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)-takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))-dropOne n = composeN n $ S.drop 1-dropAll n = composeN n $ S.drop maxValue-dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)-dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))-dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)-findIndices n = composeN n $ S.findIndices (== maxValue)-elemIndices n = composeN n $ S.elemIndices maxValue-insertBy n = composeN n $ S.insertBy compare maxValue-deleteBy n = composeN n $ S.deleteBy (>=) maxValue-reverse n = composeN n $ S.reverse-foldrS n = composeN n $ S.foldrS S.cons S.nil-foldrSMap n = composeN n $ S.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil-foldrT n = composeN n $ S.foldrT S.cons S.nil-foldrTMap n = composeN n $ S.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource- :: S.MonadAsync m- => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)- where- f (0 :: Int) m = g m- f x m = g (f (x P.- 1) m)--{-# INLINE iterateMapM #-}-{-# INLINE iterateScan #-}-{-# INLINE iterateScanl1 #-}-{-# INLINE iterateFilterEven #-}-{-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateScanl1, iterateFilterEven, iterateTakeAll,- iterateDropOne, iterateDropWhileFalse, iterateDropWhileTrue- :: S.MonadAsync m- => Int -> Stream m Int---- this is quadratic-iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)--- so is this-iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10)--iterateMapM = iterateSource (S.mapM return) maxIters-iterateFilterEven = iterateSource (S.filter even) maxIters-iterateTakeAll = iterateSource (S.take maxValue) maxIters-iterateDropOne = iterateSource (S.drop 1) maxIters-iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue)) maxIters-iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters------------------------------------------------------------------------------------ Zipping and concat----------------------------------------------------------------------------------{-# INLINE zip #-}-{-# INLINE zipM #-}-{-# INLINE mergeBy #-}-zip, zipM, mergeBy :: Monad m => Stream m Int -> m ()--zip src = do- r <- S.tail src- let src1 = fromJust r- transform (S.zipWith (,) src src1)-zipM src = do- r <- S.tail src- let src1 = fromJust r- transform (S.zipWithM (curry return) src src1)--mergeBy src = do- r <- S.tail src- let src1 = fromJust r- transform (S.mergeBy P.compare src src1)--{-# INLINE isPrefixOf #-}-{-# INLINE isSubsequenceOf #-}-isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool--isPrefixOf src = S.isPrefixOf src src-isSubsequenceOf src = S.isSubsequenceOf src src--{-# INLINE stripPrefix #-}-stripPrefix :: Monad m => Stream m Int -> m ()-stripPrefix src = do- _ <- S.stripPrefix src src- return ()--{-# INLINE zipAsync #-}-{-# INLINE zipAsyncM #-}-{-# INLINE zipAsyncAp #-}-zipAsync, zipAsyncAp, zipAsyncM :: S.MonadAsync m => Stream m Int -> m ()--zipAsync src = do- r <- S.tail src- let src1 = fromJust r- transform (S.zipAsyncWith (,) src src1)--zipAsyncM src = do- r <- S.tail src- let src1 = fromJust r- transform (S.zipAsyncWithM (curry return) src src1)--zipAsyncAp src = do- r <- S.tail src- let src1 = fromJust r- transform (S.zipAsyncly $ (,) <$> S.serially src- <*> S.serially src1)--{-# INLINE eqBy #-}-eqBy :: (Monad m, P.Eq a) => Stream m a -> m P.Bool-eqBy src = S.eqBy (==) src src--{-# INLINE cmpBy #-}-cmpBy :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering-cmpBy src = S.cmpBy P.compare src src--concatStreamLen, maxNested :: Int-concatStreamLen = 1-maxNested = 100000--{-# INLINE concatMap #-}-concatMap :: S.MonadAsync m => Int -> Stream m Int-concatMap n = S.concatMap (\_ -> sourceUnfoldrMN maxNested n)- (sourceUnfoldrMN concatStreamLen n)------------------------------------------------------------------------------------ Mixed Composition----------------------------------------------------------------------------------{-# INLINE scanMap #-}-{-# INLINE dropMap #-}-{-# INLINE dropScan #-}-{-# INLINE takeDrop #-}-{-# INLINE takeScan #-}-{-# INLINE takeMap #-}-{-# INLINE filterDrop #-}-{-# INLINE filterTake #-}-{-# INLINE filterScan #-}-{-# INLINE filterScanl1 #-}-{-# INLINE filterMap #-}-scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,- filterTake, filterScan, filterScanl1, filterMap- :: Monad m => Int -> Stream m Int -> m ()--scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop n = composeN n $ S.drop 1 . S.take maxValue-takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue-takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue-filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)-filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)-filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)--data Pair a b = Pair !a !b deriving (Generic, NFData)--{-# INLINE sumProductFold #-}-sumProductFold :: Monad m => Stream m Int -> m (Int, Int)-sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1)--{-# INLINE sumProductScan #-}-sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)-sumProductScan = S.foldl' (\(Pair _ p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1)- . S.scanl' (\(s,_) x -> (s + x,x)) (0,0)------------------------------------------------------------------------------------ Pure stream operations-----------------------------------------------------------------------------------}-{-# INLINE eqInstance #-}-eqInstance :: Stream Int -> Bool-eqInstance src = src == src--{-# INLINE eqInstanceNotEq #-}-eqInstanceNotEq :: Stream Int -> Bool-eqInstanceNotEq src = src P./= src--{-# INLINE ordInstance #-}-ordInstance :: Stream Int -> Bool-ordInstance src = src P.< src--{-# INLINE ordInstanceMin #-}-ordInstanceMin :: Stream Int -> Stream Int-ordInstanceMin src = P.min src src--{-# INLINE showInstance #-}-showInstance :: Stream Int -> P.String-showInstance src = P.show src--{-# INLINE readInstance #-}-readInstance :: P.String -> Stream Int-readInstance str =- let r = P.reads str- in case r of- [(x,"")] -> x- _ -> P.error "readInstance: no parse"--{-# INLINE pureFoldl' #-}-pureFoldl' :: MonadIO m => Stream Int -> m Int-pureFoldl' = S.foldl' (+) 0 . S.unfold A.read--#ifdef DEVBUILD-{-# INLINE foldableFoldl' #-}-foldableFoldl' :: Stream Int -> Int-foldableFoldl' = F.foldl' (+) 0--{-# INLINE foldableSum #-}-foldableSum :: Stream Int -> Int-foldableSum = P.sum-#endif--{--{-# INLINE traversableMapM #-}-traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)-traversableMapM = P.mapM return--}
− benchmark/BaseStreams.hs
@@ -1,380 +0,0 @@--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--{-# LANGUAGE CPP #-}--import Control.DeepSeq (NFData(..))--- import Data.Functor.Identity (Identity, runIdentity)-import System.Random (randomRIO)--import Gauge-import qualified StreamDOps as D-import qualified StreamKOps as K-import qualified StreamDKOps as DK-import qualified Data.List as List--#if !MIN_VERSION_deepseq(1,4,3)-instance NFData Ordering where rnf = (`seq` ())-#endif---- We need a monadic bind here to make sure that the function f does not get--- completely optimized out by the compiler in some cases.-{-# INLINE benchIO #-}-benchIO :: String -> (a IO Int -> IO ()) -> (Int -> a IO Int) -> Benchmark-benchIO name run f = bench name $ nfIO $ randomRIO (1,1) >>= run . f--{-# INLINE _benchIOSrcK #-}-_benchIOSrcK- :: String- -> (Int -> K.Stream IO Int)- -> Benchmark-_benchIOSrcK name f = bench name $ nfIO $ randomRIO (1,1) >>= K.toNull . f--{-# INLINE _benchIOSrcD #-}-_benchIOSrcD- :: String- -> (Int -> D.Stream IO Int)- -> Benchmark-_benchIOSrcD name f = bench name $ nfIO $ randomRIO (1,1) >>= D.toNull . f--benchFold :: NFData b- => String -> (t IO Int -> IO b) -> (Int -> t IO Int) -> Benchmark-benchFold name f src = bench name $ nfIO $ randomRIO (1,1) >>= f . src--#ifdef DEVBUILD--- | Takes a source, and uses it with a default drain/fold method.-{-# INLINE benchD #-}-benchD :: String -> (Int -> D.Stream IO Int) -> Benchmark-benchD name f = bench name $ nfIO $ randomRIO (1,1) >>= D.toNull . f--{-# INLINE benchK #-}-benchK :: String -> (Int -> K.Stream IO Int) -> Benchmark-benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= K.toNull . f-#endif--{--_benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark-_benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10)--}--{-# INLINE benchPure #-}-benchPure :: String -> ([Int] -> [Int]) -> (Int -> [Int]) -> Benchmark-benchPure name run f = bench name $ nfIO $ randomRIO (1,1) >>= return . run . f--main :: IO ()-main =- defaultMain- [ bgroup "streamD"- [ bgroup "generation"- [ benchIO "unfoldr" D.toNull D.sourceUnfoldr- , benchIO "unfoldrM" D.toNull D.sourceUnfoldrM- , benchIO "intFromTo" D.toNull D.sourceIntFromTo-- , benchIO "fromList" D.toNull D.sourceFromList- -- , benchIO "fromFoldableM" D.sourceFromFoldableM- ]- , bgroup "elimination"- [ benchIO "toNull" D.toNull D.sourceUnfoldrM- , benchIO "mapM_" D.mapM_ D.sourceUnfoldrM- , benchIO "uncons" D.uncons D.sourceUnfoldrM-#ifdef DEVBUILD- -- XXX these consume too much stack space, need to fix or segregate in- -- another benchmark.- , benchFold "tail" D.tail D.sourceUnfoldrM- , benchIO "nullTail" D.nullTail D.sourceUnfoldrM- , benchIO "headTail" D.headTail D.sourceUnfoldrM- , benchFold "toList" D.toList D.sourceUnfoldrM-#endif- , benchFold "foldl'" D.foldl D.sourceUnfoldrM- , benchFold "last" D.last D.sourceUnfoldrM- ]- , bgroup "nested"- [ benchIO "toNullAp" D.toNullApNested (D.sourceUnfoldrMN D.value2)- , benchIO "toNull" D.toNullNested (D.sourceUnfoldrMN D.value2)- , benchIO "toNull3" D.toNullNested3 (D.sourceUnfoldrMN D.value3)- , benchIO "filterAllIn" D.filterAllInNested (D.sourceUnfoldrMN K.value2)- , benchIO "filterAllOut" D.filterAllOutNested (D.sourceUnfoldrMN K.value2)- , benchIO "toNullApPure" D.toNullApNested (D.sourceUnfoldrN K.value2)- , benchIO "toNullPure" D.toNullNested (D.sourceUnfoldrN K.value2)- , benchIO "toNull3Pure" D.toNullNested3 (D.sourceUnfoldrN K.value3)- , benchIO "filterAllInPure" D.filterAllInNested (D.sourceUnfoldrN K.value2)- , benchIO "filterAllOutPure" D.filterAllOutNested (D.sourceUnfoldrN K.value2)- ]- , bgroup "transformation"- [ benchIO "scan" (D.scan 1) D.sourceUnfoldrM- , benchIO "map" (D.map 1) D.sourceUnfoldrM- , benchIO "fmap" (D.fmap 1) D.sourceUnfoldrM- , benchIO "mapM" (D.mapM 1) D.sourceUnfoldrM- , benchIO "mapMaybe" (D.mapMaybe 1) D.sourceUnfoldrM- , benchIO "mapMaybeM" (D.mapMaybeM 1) D.sourceUnfoldrM- , benchIO "concatMapNxN" (D.concatMap 1) (D.sourceUnfoldrMN D.value2)- , benchIO "concatMapRepl4xN" D.concatMapRepl4xN- (D.sourceUnfoldrMN (D.value `div` 4))- , benchIO "concatMapPureNxN" (D.concatMap 1) (D.sourceUnfoldrN D.value2)- , benchIO "concatMapURepl4xN" D.concatMapURepl4xN- (D.sourceUnfoldrMN (D.value `div` 4))- , benchIO "intersperse" (D.intersperse 1) (D.sourceUnfoldrMN D.value2)- , benchIO "interspersePure" (D.intersperse 1) (D.sourceUnfoldrN D.value2)- -- , benchIO "foldrS" (D.foldrS 1) D.sourceUnfoldrM- -- This has horrible performance, never finishes- -- , benchIO "foldlS" (D.foldlS 1) D.sourceUnfoldrM- ]- , bgroup "transformationX4"- [ benchIO "scan" (D.scan 4) D.sourceUnfoldrM- , benchIO "map" (D.map 4) D.sourceUnfoldrM- , benchIO "fmap" (D.fmap 4) D.sourceUnfoldrM- , benchIO "mapM" (D.mapM 4) D.sourceUnfoldrM- , benchIO "mapMaybe" (D.mapMaybe 4) D.sourceUnfoldrM- , benchIO "mapMaybeM" (D.mapMaybeM 4) D.sourceUnfoldrM- -- , benchIO "concatMap" (D.concatMap 4) (D.sourceUnfoldrMN D.value16)- , benchIO "intersperse" (D.intersperse 4) (D.sourceUnfoldrMN D.value16)- ]- , bgroup "filtering"- [ benchIO "filter-even" (D.filterEven 1) D.sourceUnfoldrM- , benchIO "filter-all-out" (D.filterAllOut 1) D.sourceUnfoldrM- , benchIO "filter-all-in" (D.filterAllIn 1) D.sourceUnfoldrM- , benchIO "take-all" (D.takeAll 1) D.sourceUnfoldrM- , benchIO "takeWhile-true" (D.takeWhileTrue 1) D.sourceUnfoldrM- , benchIO "drop-one" (D.dropOne 1) D.sourceUnfoldrM- , benchIO "drop-all" (D.dropAll 1) D.sourceUnfoldrM- , benchIO "dropWhile-true" (D.dropWhileTrue 1) D.sourceUnfoldrM- , benchIO "dropWhile-false" (D.dropWhileFalse 1) D.sourceUnfoldrM- ]- , bgroup "filteringX4"- [ benchIO "filter-even" (D.filterEven 4) D.sourceUnfoldrM- , benchIO "filter-all-out" (D.filterAllOut 4) D.sourceUnfoldrM- , benchIO "filter-all-in" (D.filterAllIn 4) D.sourceUnfoldrM- , benchIO "take-all" (D.takeAll 4) D.sourceUnfoldrM- , benchIO "takeWhile-true" (D.takeWhileTrue 4) D.sourceUnfoldrM- , benchIO "drop-one" (D.dropOne 4) D.sourceUnfoldrM- , benchIO "drop-all" (D.dropAll 4) D.sourceUnfoldrM- , benchIO "dropWhile-true" (D.dropWhileTrue 4) D.sourceUnfoldrM- , benchIO "dropWhile-false" (D.dropWhileFalse 4) D.sourceUnfoldrM- ]- , bgroup "zipping"- [ benchFold "eqBy" D.eqBy D.sourceUnfoldrM- , benchFold "cmpBy" D.cmpBy D.sourceUnfoldrM- , benchIO "zip" D.zip D.sourceUnfoldrM- ]- , bgroup "mixed"- [ benchIO "scan-map" (D.scanMap 1) D.sourceUnfoldrM- , benchIO "drop-map" (D.dropMap 1) D.sourceUnfoldrM- , benchIO "drop-scan" (D.dropScan 1) D.sourceUnfoldrM- , benchIO "take-drop" (D.takeDrop 1) D.sourceUnfoldrM- , benchIO "take-scan" (D.takeScan 1) D.sourceUnfoldrM- , benchIO "take-map" (D.takeMap 1) D.sourceUnfoldrM- , benchIO "filter-drop" (D.filterDrop 1) D.sourceUnfoldrM- , benchIO "filter-take" (D.filterTake 1) D.sourceUnfoldrM- , benchIO "filter-scan" (D.filterScan 1) D.sourceUnfoldrM- , benchIO "filter-map" (D.filterMap 1) D.sourceUnfoldrM- ]- , bgroup "mixedX2"- [ benchIO "scan-map" (D.scanMap 2) D.sourceUnfoldrM- , benchIO "drop-map" (D.dropMap 2) D.sourceUnfoldrM- , benchIO "drop-scan" (D.dropScan 2) D.sourceUnfoldrM- , benchIO "take-drop" (D.takeDrop 2) D.sourceUnfoldrM- , benchIO "take-scan" (D.takeScan 2) D.sourceUnfoldrM- , benchIO "take-map" (D.takeMap 2) D.sourceUnfoldrM- , benchIO "filter-drop" (D.filterDrop 2) D.sourceUnfoldrM- , benchIO "filter-take" (D.filterTake 2) D.sourceUnfoldrM- , benchIO "filter-scan" (D.filterScan 2) D.sourceUnfoldrM- , benchIO "filter-map" (D.filterMap 2) D.sourceUnfoldrM- ]- , bgroup "mixedX4"- [ benchIO "scan-map" (D.scanMap 4) D.sourceUnfoldrM- , benchIO "drop-map" (D.dropMap 4) D.sourceUnfoldrM- , benchIO "drop-scan" (D.dropScan 4) D.sourceUnfoldrM- , benchIO "take-drop" (D.takeDrop 4) D.sourceUnfoldrM- , benchIO "take-scan" (D.takeScan 4) D.sourceUnfoldrM- , benchIO "take-map" (D.takeMap 4) D.sourceUnfoldrM- , benchIO "filter-drop" (D.filterDrop 4) D.sourceUnfoldrM- , benchIO "filter-take" (D.filterTake 4) D.sourceUnfoldrM- , benchIO "filter-scan" (D.filterScan 4) D.sourceUnfoldrM- , benchIO "filter-map" (D.filterMap 4) D.sourceUnfoldrM- ]-#ifdef DEVBUILD- -- XXX these consume too much stack space, need to fix or segregate in- -- another benchmark.- , bgroup "iterated"- [ benchD "mapM" D.iterateMapM- , benchD "scan(1/10)" D.iterateScan- , benchD "filterEven" D.iterateFilterEven- , benchD "takeAll" D.iterateTakeAll- , benchD "dropOne" D.iterateDropOne- , benchD "dropWhileFalse(1/10)" D.iterateDropWhileFalse- , benchD "dropWhileTrue" D.iterateDropWhileTrue- , benchD "iterateM" D.iterateM-- ]-#endif- ]- , bgroup "list"- [ bgroup "elimination"- [ benchPure "last" (\xs -> [List.last xs]) (K.sourceUnfoldrList K.value)- ]- , bgroup "nested"- [ benchPure "toNullAp" K.toNullApNestedList (K.sourceUnfoldrList K.value2)- , benchPure "toNull" K.toNullNestedList (K.sourceUnfoldrList K.value2)- , benchPure "toNull3" K.toNullNestedList3 (K.sourceUnfoldrList K.value3)- , benchPure "filterAllIn" K.filterAllInNestedList (K.sourceUnfoldrList K.value2)- , benchPure "filterAllOut" K.filterAllOutNestedList (K.sourceUnfoldrList K.value2)- ]- ]- , bgroup "streamK"- [ bgroup "generation"- [ benchIO "unfoldr" K.toNull K.sourceUnfoldr- , benchIO "unfoldrM" K.toNull K.sourceUnfoldrM- -- , benchIO "fromEnum" K.toNull K.sourceFromEnum-- , benchIO "fromFoldable" K.toNull K.sourceFromFoldable- -- , benchIO "fromFoldableM" K.toNull K.sourceFromFoldableM-- -- appends- , benchIO "foldMapWith" K.toNull K.sourceFoldMapWith- , benchIO "foldMapWithM" K.toNull K.sourceFoldMapWithM- ]- , bgroup "elimination"- [ benchIO "toNull" K.toNull K.sourceUnfoldrM- , benchIO "mapM_" K.mapM_ K.sourceUnfoldrM- , benchIO "uncons" K.uncons K.sourceUnfoldrM- , benchFold "init" K.init K.sourceUnfoldrM-#ifdef DEVBUILD- -- XXX these consume too much stack space, need to fix or segregate in- -- another benchmark.- , benchFold "tail" K.tail K.sourceUnfoldrM- , benchIO "nullTail" K.nullTail K.sourceUnfoldrM- , benchIO "headTail" K.headTail K.sourceUnfoldrM- , benchFold "toList" K.toList K.sourceUnfoldrM-#endif- , benchFold "foldl'" K.foldl K.sourceUnfoldrM- , benchFold "last" K.last K.sourceUnfoldrM- ]- , bgroup "nested"- [ benchIO "toNullAp" K.toNullApNested (K.sourceUnfoldrMN K.value2)- , benchIO "toNull" K.toNullNested (K.sourceUnfoldrMN K.value2)- , benchIO "toNull3" K.toNullNested3 (K.sourceUnfoldrMN K.value3)- , benchIO "filterAllIn" K.filterAllInNested (K.sourceUnfoldrMN K.value2)- , benchIO "filterAllOut" K.filterAllOutNested (K.sourceUnfoldrMN K.value2)- , benchIO "toNullApPure" K.toNullApNested (K.sourceUnfoldrN K.value2)- , benchIO "toNullPure" K.toNullNested (K.sourceUnfoldrN K.value2)- , benchIO "toNull3Pure" K.toNullNested3 (K.sourceUnfoldrN K.value3)- , benchIO "filterAllInPure" K.filterAllInNested (K.sourceUnfoldrN K.value2)- , benchIO "filterAllOutPure" K.filterAllOutNested (K.sourceUnfoldrN K.value2)- ]- , bgroup "transformation"- [ benchIO "scan" (K.scan 1) K.sourceUnfoldrM- , benchIO "map" (K.map 1) K.sourceUnfoldrM- , benchIO "fmap" (K.fmap 1) K.sourceUnfoldrM- , benchIO "mapM" (K.mapM 1) K.sourceUnfoldrM- , benchIO "mapMSerial" (K.mapMSerial 1) K.sourceUnfoldrM- -- , benchIOSrcK "concatMap" K.concatMap- , benchIO "concatMapNxN" (K.concatMap 1) (K.sourceUnfoldrMN K.value2)- , benchIO "concatMapPureNxN" (K.concatMap 1) (K.sourceUnfoldrN K.value2)- , benchIO "concatMapRepl4xN" K.concatMapRepl4xN- (K.sourceUnfoldrMN (K.value `div` 4))- , benchIO "intersperse" (K.intersperse 1) (K.sourceUnfoldrMN K.value2)- , benchIO "interspersePure" (K.intersperse 1) (K.sourceUnfoldrN K.value2)-#ifdef DEVBUILD- -- XXX this consumes too much heap- , benchIO "foldlS" (K.foldlS 1) K.sourceUnfoldrM-#endif- ]- , bgroup "transformationX4"- [ benchIO "scan" (K.scan 4) K.sourceUnfoldrM- , benchIO "map" (K.map 4) K.sourceUnfoldrM- , benchIO "fmap" (K.fmap 4) K.sourceUnfoldrM- , benchIO "mapM" (K.mapM 4) K.sourceUnfoldrM- , benchIO "mapMSerial" (K.mapMSerial 4) K.sourceUnfoldrM- -- , benchIO "concatMap" (K.concatMap 4) (K.sourceUnfoldrMN K.value16)- , benchIO "intersperse" (K.intersperse 4) (K.sourceUnfoldrMN K.value16)- ]- , bgroup "filtering"- [ benchIO "filter-even" (K.filterEven 1) K.sourceUnfoldrM- , benchIO "filter-all-out" (K.filterAllOut 1) K.sourceUnfoldrM- , benchIO "filter-all-in" (K.filterAllIn 1) K.sourceUnfoldrM- , benchIO "take-all" (K.takeAll 1) K.sourceUnfoldrM- , benchIO "takeWhile-true" (K.takeWhileTrue 1) K.sourceUnfoldrM- , benchIO "drop-one" (K.dropOne 1) K.sourceUnfoldrM- , benchIO "drop-all" (K.dropAll 1) K.sourceUnfoldrM- , benchIO "dropWhile-true" (K.dropWhileTrue 1) K.sourceUnfoldrM- , benchIO "dropWhile-false" (K.dropWhileFalse 1) K.sourceUnfoldrM- ]- , bgroup "filteringX4"- [ benchIO "filter-even" (K.filterEven 4) K.sourceUnfoldrM- , benchIO "filter-all-out" (K.filterAllOut 4) K.sourceUnfoldrM- , benchIO "filter-all-in" (K.filterAllIn 4) K.sourceUnfoldrM- , benchIO "take-all" (K.takeAll 4) K.sourceUnfoldrM- , benchIO "takeWhile-true" (K.takeWhileTrue 4) K.sourceUnfoldrM- , benchIO "drop-one" (K.dropOne 4) K.sourceUnfoldrM- , benchIO "drop-all" (K.dropAll 4) K.sourceUnfoldrM- , benchIO "dropWhile-true" (K.dropWhileTrue 4) K.sourceUnfoldrM- , benchIO "dropWhile-false" (K.dropWhileFalse 4) K.sourceUnfoldrM- ]- , bgroup "zipping"- [ benchIO "zip" K.zip K.sourceUnfoldrM- ]- , bgroup "mixed"- [ benchIO "scan-map" (K.scanMap 1) K.sourceUnfoldrM- , benchIO "drop-map" (K.dropMap 1) K.sourceUnfoldrM- , benchIO "drop-scan" (K.dropScan 1) K.sourceUnfoldrM- , benchIO "take-drop" (K.takeDrop 1) K.sourceUnfoldrM- , benchIO "take-scan" (K.takeScan 1) K.sourceUnfoldrM- , benchIO "take-map" (K.takeMap 1) K.sourceUnfoldrM- , benchIO "filter-drop" (K.filterDrop 1) K.sourceUnfoldrM- , benchIO "filter-take" (K.filterTake 1) K.sourceUnfoldrM- , benchIO "filter-scan" (K.filterScan 1) K.sourceUnfoldrM- , benchIO "filter-map" (K.filterMap 1) K.sourceUnfoldrM- ]- , bgroup "mixedX2"- [ benchIO "scan-map" (K.scanMap 2) K.sourceUnfoldrM- , benchIO "drop-map" (K.dropMap 2) K.sourceUnfoldrM- , benchIO "drop-scan" (K.dropScan 2) K.sourceUnfoldrM- , benchIO "take-drop" (K.takeDrop 2) K.sourceUnfoldrM- , benchIO "take-scan" (K.takeScan 2) K.sourceUnfoldrM- , benchIO "take-map" (K.takeMap 2) K.sourceUnfoldrM- , benchIO "filter-drop" (K.filterDrop 2) K.sourceUnfoldrM- , benchIO "filter-take" (K.filterTake 2) K.sourceUnfoldrM- , benchIO "filter-scan" (K.filterScan 2) K.sourceUnfoldrM- , benchIO "filter-map" (K.filterMap 2) K.sourceUnfoldrM- ]- , bgroup "mixedX4"- [ benchIO "scan-map" (K.scanMap 4) K.sourceUnfoldrM- , benchIO "drop-map" (K.dropMap 4) K.sourceUnfoldrM- , benchIO "drop-scan" (K.dropScan 4) K.sourceUnfoldrM- , benchIO "take-drop" (K.takeDrop 4) K.sourceUnfoldrM- , benchIO "take-scan" (K.takeScan 4) K.sourceUnfoldrM- , benchIO "take-map" (K.takeMap 4) K.sourceUnfoldrM- , benchIO "filter-drop" (K.filterDrop 4) K.sourceUnfoldrM- , benchIO "filter-take" (K.filterTake 4) K.sourceUnfoldrM- , benchIO "filter-scan" (K.filterScan 4) K.sourceUnfoldrM- , benchIO "filter-map" (K.filterMap 4) K.sourceUnfoldrM- ]-#ifdef DEVBUILD- -- XXX these consume too much stack space, need to fix or segregate in- -- another benchmark.- , bgroup "iterated"- [ benchK "mapM" K.iterateMapM- , benchK "scan(1/10)" K.iterateScan- , benchK "filterEven" K.iterateFilterEven- , benchK "takeAll" K.iterateTakeAll- , benchK "dropOne" K.iterateDropOne- , benchK "dropWhileFalse(1/10)" K.iterateDropWhileFalse- , benchK "dropWhileTrue" K.iterateDropWhileTrue- ]-#endif- ]- , bgroup "streamDK"- [ bgroup "generation"- [ benchIO "unfoldr" DK.toNull DK.sourceUnfoldr- , benchIO "unfoldrM" DK.toNull DK.sourceUnfoldrM- ]- , bgroup "elimination"- [ benchIO "toNull" DK.toNull DK.sourceUnfoldrM- , benchIO "uncons" DK.uncons DK.sourceUnfoldrM- ]- ]- ]
benchmark/Chart.hs view
@@ -27,9 +27,8 @@ = Linear | LinearAsync | LinearRate- | Nested | NestedConcurrent- | NestedUnfold+ | Parser | Base | FileIO | Array@@ -40,6 +39,10 @@ | Concurrent | Parallel | Adaptive+ | FoldO1Space+ | FoldOnHeap+ | UnfoldO1Space+ | UnfoldOnSpace deriving Show data Options = Options@@ -77,9 +80,8 @@ Just "linear" -> setBenchType Linear Just "linear-async" -> setBenchType LinearAsync Just "linear-rate" -> setBenchType LinearRate- Just "nested" -> setBenchType Nested Just "nested-concurrent" -> setBenchType NestedConcurrent- Just "nested-unfold" -> setBenchType NestedUnfold+ Just "parser" -> setBenchType Parser Just "base" -> setBenchType Base Just "fileio" -> setBenchType FileIO Just "array-cmp" -> setBenchType ArrayCmp@@ -90,6 +92,10 @@ Just "concurrent" -> setBenchType Concurrent Just "parallel" -> setBenchType Parallel Just "adaptive" -> setBenchType Adaptive+ Just "fold-o-1-space" -> setBenchType FoldO1Space+ Just "fold-o-n-heap" -> setBenchType FoldOnHeap+ Just "unfold-o-1-space" -> setBenchType UnfoldO1Space+ Just "unfold-o-n-space" -> setBenchType UnfoldOnSpace Just str -> do liftIO $ putStrLn $ "unrecognized benchmark type " <> str mzero@@ -186,24 +192,22 @@ } --------------------------------------------------------------------------------- Nested composition charts+-- Stream type based comparison charts ------------------------------------------------------------------------------ -makeNestedGraphs :: Config -> String -> IO ()-makeNestedGraphs cfg inputFile =- ignoringErr $ graph inputFile "nested-all" $ cfg+makeStreamComparisonGraphs :: String -> [String] -> Config -> String -> IO ()+makeStreamComparisonGraphs outputPrefix benchPrefixes cfg inputFile =+ ignoringErr $ graph inputFile outputPrefix $ cfg { presentation = Groups Absolute , classifyBenchmark = classifyNested , selectGroups = \gs -> groupBy ((==) `on` snd) gs- & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)+ & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) benchPrefixes) & concat } where - order = ["serially", "asyncly", "wAsyncly", "aheadly", "parallely"]- classifyNested b | "serially/" `isPrefixOf` b = ("serially",) <$> stripPrefix "serially/" b@@ -217,48 +221,8 @@ ("parallely",) <$> stripPrefix "parallely/" b | otherwise = Nothing ---------------------------------------------------------------------------------- Charts for parallel streams---------------------------------------------------------------------------------makeLinearAsyncGraphs :: Config -> String -> IO ()-makeLinearAsyncGraphs cfg inputFile =- ignoringErr $ graph inputFile "linear-async" cfg- { presentation = Groups Absolute- , classifyBenchmark = classifyAsync- , selectGroups = \gs ->- groupBy ((==) `on` snd) gs- & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)- & concat- }-- where-- order = ["asyncly", "wAsyncly", "aheadly", "parallely"]-- classifyAsync b- | "asyncly/" `isPrefixOf` b =- ("asyncly",) <$> stripPrefix "asyncly/" b- | "wAsyncly/" `isPrefixOf` b =- ("wAsyncly",) <$> stripPrefix "wAsyncly/" b- | "aheadly/" `isPrefixOf` b =- ("aheadly",) <$> stripPrefix "aheadly/" b- | "parallely/" `isPrefixOf` b =- ("parallely",) <$> stripPrefix "parallely/" b- | otherwise = Nothing--makeLinearRateGraphs :: Config -> String -> IO ()-makeLinearRateGraphs cfg inputFile = do- putStrLn "Not implemented"- return ()----------------------------------------------------------------------------------- FileIO---------------------------------------------------------------------------------makeFileIOGraphs :: Config -> String -> IO ()-makeFileIOGraphs cfg@Config{..} inputFile =- ignoringErr $ graph inputFile "fileIO" cfg+linearAsyncPrefixes = ["asyncly", "wAsyncly", "aheadly", "parallely"]+nestedBenchPrefixes = ["serially"] ++ linearAsyncPrefixes ------------------------------------------------------------------------------ -- Generic@@ -383,34 +347,29 @@ makeLinearGraphs "charts/linear/results.csv" "charts/linear"- LinearAsync -> benchShow opts cfg- { title = Just "Linear Async" }- makeLinearAsyncGraphs- "charts/linear-async/results.csv"- "charts/linear-async" LinearRate -> benchShow opts cfg { title = Just "Linear Rate" }- makeLinearRateGraphs+ (makeGraphs "linear-rate") "charts/linear-rate/results.csv" "charts/linear-rate"- Nested -> benchShow opts cfg- { title = Just "Nested loops" }- makeNestedGraphs- "charts/nested/results.csv"- "charts/nested"+ LinearAsync -> benchShow opts cfg+ { title = Just "Linear Async" }+ (makeStreamComparisonGraphs "linear-async" linearAsyncPrefixes)+ "charts/linear-async/results.csv"+ "charts/linear-async" NestedConcurrent -> benchShow opts cfg { title = Just "Nested concurrent loops" }- makeNestedGraphs+ (makeStreamComparisonGraphs "nested-concurrent" nestedBenchPrefixes) "charts/nested-concurrent/results.csv" "charts/nested-concurrent"- NestedUnfold -> benchShow opts cfg- { title = Just "Nested unfold loops" }- makeNestedGraphs- "charts/nested-unfold/results.csv"- "charts/nested-unfold"+ Parser -> benchShow opts cfg+ { title = Just "Parsers" }+ (makeGraphs "parser")+ "charts/parser/results.csv"+ "charts/parser" FileIO -> benchShow opts cfg { title = Just "File IO" }- makeFileIOGraphs+ (makeGraphs "fileIO") "charts/fileio/results.csv" "charts/fileio" Array -> benchShow opts cfg@@ -465,3 +424,23 @@ showStreamK opts cfg' "charts/base/results.csv" "charts/base"+ FoldO1Space -> benchShow opts cfg+ { title = Just "Fold O(1) Space" }+ (makeGraphs "fold-o-1-space")+ "charts/fold-o-1-space/results.csv"+ "charts/fold-o-1-space"+ FoldOnHeap -> benchShow opts cfg+ { title = Just "Fold O(n) Heap" }+ (makeGraphs "fold-o-n-heap")+ "charts/fold-o-n-heap/results.csv"+ "charts/fold-o-n-heap"+ UnfoldO1Space -> benchShow opts cfg+ { title = Just "Unfold O(1) Space" }+ (makeGraphs "unfold-o-1-space")+ "charts/unfold-o-1-space/results.csv"+ "charts/unfold-o-1-space"+ UnfoldOnSpace -> benchShow opts cfg+ { title = Just "Unfold O(n) Space" }+ (makeGraphs "unfold-o-n-space")+ "charts/unfold-o-n-space/results.csv"+ "charts/unfold-o-n-space"
− benchmark/Common.hs
@@ -1,95 +0,0 @@--- |--- Module : Main--- Copyright : (c) 2019 Composewell Technologies------ License : BSD3--- Maintainer : streamly@composewell.com--module Common (parseCLIOpts) where--import Control.Exception (evaluate)-import Control.Monad (when)-import Data.List (scanl')-import Data.Maybe (catMaybes)-import System.Console.GetOpt- (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt')-import System.Environment (getArgs, lookupEnv, setEnv)-import Text.Read (readMaybe)--import Gauge------------------------------------------------------------------------------------ Parse custom CLI options----------------------------------------------------------------------------------data BenchOpts = StreamSize Int deriving Show--getStreamSize :: String -> Int-getStreamSize size =- case (readMaybe size :: Maybe Int) of- Just x -> x- Nothing -> error "Stream size must be numeric"--options :: [OptDescr BenchOpts]-options =- [- Option [] ["stream-size"] (ReqArg getSize "COUNT") "Stream element count"- ]-- where-- getSize = StreamSize . getStreamSize--deleteOptArgs- :: (Maybe String, Maybe String) -- (prev, yielded)- -> String- -> (Maybe String, Maybe String)-deleteOptArgs (Nothing, _) opt =- if opt == "--stream-size"- then (Just opt, Nothing)- else (Just opt, Just opt)--deleteOptArgs (Just prev, _) opt =- if opt == "--stream-size" || prev == "--stream-size"- then (Just opt, Nothing)- else (Just opt, Just opt)--parseCLIOpts :: Int -> IO (Int, Config, [String])-parseCLIOpts defaultStreamSize = do- args <- getArgs-- -- Parse custom options- let (opts, _, _, errs) = getOpt' Permute options args- when (not $ null errs) $ error $ concat errs- (streamSize, args') <-- case opts of- StreamSize x : _ -> do- -- When using the gauge "--measure-with" option we need to make- -- sure that we pass the stream size to child process forked by- -- gauge. So we use this env var for that purpose.- setEnv "STREAM_SIZE" (show x)- -- Hack! remove the option and its argument from args- -- getOpt should have a way to return the unconsumed args in- -- correct order.- newArgs <-- evaluate- $ catMaybes- $ map snd- $ scanl' deleteOptArgs (Nothing, Nothing) args- return (x, newArgs)- _ -> do- r <- lookupEnv "STREAM_SIZE"- case r of- Just x -> do- s <- evaluate $ getStreamSize x- return (s, args)- Nothing -> return (defaultStreamSize, args)-- -- Parse gauge options- let config = defaultConfig- { timeLimit = Just 1- , minDuration = 0- , includeFirstIter = streamSize > defaultStreamSize- }- let (cfg, benches) = parseWith config args'- streamSize `seq` return (streamSize, cfg, benches)
− benchmark/Concurrent.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.Concurrent-import Control.Monad (when, replicateM)--import Gauge-import Streamly-import qualified Streamly.Prelude as S------------------------------------------------------------------------------------ Append------------------------------------------------------------------------------------ | Run @tcount@ number of actions concurrently using the given concurrency--- style. Each thread produces a single output after a delay of @d@--- microseconds.----{-# INLINE append #-}-append :: IsStream t- => Int -> Int -> Int -> (t IO Int -> SerialT IO Int) -> IO ()-append buflen tcount d t =- let work = (\i -> when (d /= 0) (threadDelay d) >> return i)- in S.drain- $ t- $ maxBuffer buflen- $ maxThreads (-1)- $ S.fromFoldableM $ map work [1..tcount]---- | Run @threads@ concurrently, each producing streams of @elems@ elements--- with a delay of @d@ microseconds between successive elements, and merge--- their outputs in a single output stream. The individual streams are produced--- serially but merged using the provided concurrency style.----{-# INLINE concated #-}-concated- :: Int- -> Int- -> Int- -> Int- -> (forall a. SerialT IO a -> SerialT IO a -> SerialT IO a)- -> IO ()-concated buflen threads d elems t =- let work = \i -> S.replicateM i- ((when (d /= 0) (threadDelay d)) >> return i)- in S.drain- $ adapt- $ maxThreads (-1)- $ maxBuffer buflen- $ S.concatMapWith t work- $ S.replicate threads elems--appendGroup :: Int -> Int -> Int -> [Benchmark]-appendGroup buflen threads delay =- [ -- bench "serial" $ nfIO $ append buflen threads delay serially- bench "ahead" $ nfIO $ append buflen threads delay aheadly- , bench "async" $ nfIO $ append buflen threads delay asyncly- , bench "wAsync" $ nfIO $ append buflen threads delay wAsyncly- , bench "parallel" $ nfIO $ append buflen threads delay parallely- ]--concatGroup :: Int -> Int -> Int -> Int -> [Benchmark]-concatGroup buflen threads delay n =- [ bench "serial" $ nfIO $ concated buflen threads delay n serial- , bench "ahead" $ nfIO $ concated buflen threads delay n ahead- , bench "async" $ nfIO $ concated buflen threads delay n async- , bench "wAsync" $ nfIO $ concated buflen threads delay n wAsync- , bench "parallel" $ nfIO $ concated buflen threads delay n parallel- ]--main :: IO ()-main = do- defaultMainWith (defaultConfig- { timeLimit = Just 0- , minSamples = Just 1- , minDuration = 0- , includeFirstIter = True- , quickMode = True- })-- [ -- bgroup "append/buf-1-threads-10k-0sec" (appendGroup 1 10000 0)- -- , bgroup "append/buf-100-threads-100k-0sec" (appendGroup 100 100000 0)- bgroup "stream1x10k/buf10k-threads10k-5sec" (appendGroup 10000 10000 5000000)- -- bgroup "concat/buf-1-threads-100k-count-1" (concatGroup 1 100000 0 1)- -- bgroup "concat/buf-1-threads-1-count-10m" (concatGroup 1 1 0 10000000)- , bgroup "streams100x500k/buf100-threads100" (concatGroup 100 100 0 500000)-- , bench "forkIO/threads10k-5sec" $- let delay = threadDelay 5000000- count = 10000 :: Int- list = [1..count]- work i = delay >> return i- in nfIO $ do- ref <- newEmptyMVar- mapM_ (\i -> forkIO $ work i >>=- \j -> putMVar ref j) list- replicateM 10000 (takeMVar ref)- ]
benchmark/FileIO.hs view
@@ -212,6 +212,12 @@ , mkBench "sumChunksOf 1" href $ do Handles inh _ <- readIORef href BFS.chunksOfSum 1 inh+ , mkBench "sumChunksOf (single chunk) (splitParse)" href $ do+ Handles inh _ <- readIORef href+ BFS.splitParseChunksOfSum fileSize inh+ , mkBench "sumChunksOf 1 (splitParse)" href $ do+ Handles inh _ <- readIORef href+ BFS.splitParseChunksOfSum 1 inh , mkBench "arraysOf 1" href $ do Handles inh _ <- readIORef href@@ -262,6 +268,9 @@ , mkBench "splitOnSuffix \\n (line count)" href $ do Handles inh _ <- readIORef href BFS.splitOnSuffix inh+ , mkBench "splitOn \\n (line count) (splitParse)" href $ do+ Handles inh _ <- readIORef href+ BFS.splitParseSepBy inh , mkBench "wordsBy isSpace (word count)" href $ do Handles inh _ <- readIORef href BFS.wordsBy inh
− benchmark/Linear.hs
@@ -1,575 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-orphans #-}-#endif---- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.DeepSeq (NFData(..), deepseq)-import Control.Monad (when)-import Data.Functor.Identity (Identity, runIdentity)-import Data.Monoid (Last(..))-import System.Random (randomRIO)--import Common (parseCLIOpts)--import qualified GHC.Exts as GHC-import qualified Streamly.Benchmark.Prelude as Ops--import Streamly-import qualified Streamly.Data.Fold as FL-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S-import qualified Streamly.Internal.Data.Sink as Sink--import Streamly.Internal.Data.Time.Units-import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Internal.Data.Fold as IFL-import qualified Streamly.Internal.Prelude as IP-import qualified Streamly.Internal.Data.Pipe as Pipe--import Gauge----------------------------------------------------------------------------------------------------------------------------------------------------------------------#if !MIN_VERSION_deepseq(1,4,3)-instance NFData Ordering where rnf = (`seq` ())-#endif---- We need a monadic bind here to make sure that the function f does not get--- completely optimized out by the compiler in some cases.---- | Takes a fold method, and uses it with a default source.-{-# INLINE benchIOSink #-}-benchIOSink- :: (IsStream t, NFData b)- => Int -> String -> (t IO Int -> IO b) -> Benchmark-benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source value--{-# INLINE benchHoistSink #-}-benchHoistSink- :: (IsStream t, NFData b)- => Int -> String -> (t Identity Int -> IO b) -> Benchmark-benchHoistSink value name f =- bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.sourceUnfoldr value---- XXX once we convert all the functions to use this we can rename this to--- benchIOSink-{-# INLINE benchIOSink1 #-}-benchIOSink1 :: NFData b => String -> (Int -> IO b) -> Benchmark-benchIOSink1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f---- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but--- we can't use it as it requires MonadAsync constraint.-{-# INLINE benchIdentitySink #-}-benchIdentitySink- :: (IsStream t, NFData b)- => Int -> String -> (t Identity Int -> Identity b) -> Benchmark-benchIdentitySink value name f = bench name $ nf (f . Ops.sourceUnfoldr value) 1---- | Takes a source, and uses it with a default drain/fold method.-{-# INLINE benchIOSrc #-}-benchIOSrc- :: (t IO a -> SerialT IO a)- -> String- -> (Int -> t IO a)- -> Benchmark-benchIOSrc t name f =- bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f--{-# INLINE benchIOSrc1 #-}-benchIOSrc1 :: String -> (Int -> IO ()) -> Benchmark-benchIOSrc1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f--{-# INLINE benchPure #-}-benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark-benchPure name src f = bench name $ nfIO $ randomRIO (1,1) >>= return . f . src--{-# INLINE benchPureSink #-}-benchPureSink :: NFData b => Int -> String -> (SerialT Identity Int -> b) -> Benchmark-benchPureSink value name f = benchPure name (Ops.sourceUnfoldr value) f---- XXX once we convert all the functions to use this we can rename this to--- benchPureSink-{-# INLINE benchPureSink1 #-}-benchPureSink1 :: NFData b => String -> (Int -> Identity b) -> Benchmark-benchPureSink1 name f =- bench name $ nfIO $ randomRIO (1,1) >>= return . runIdentity . f--{-# INLINE benchPureSinkIO #-}-benchPureSinkIO- :: NFData b- => Int -> String -> (SerialT Identity Int -> IO b) -> Benchmark-benchPureSinkIO value name f =- bench name $ nfIO $ randomRIO (1, 1) >>= f . Ops.sourceUnfoldr value--{-# INLINE benchPureSrc #-}-benchPureSrc :: String -> (Int -> SerialT Identity a) -> Benchmark-benchPureSrc name src = benchPure name src (runIdentity . S.drain)--mkString :: Int -> String-mkString value = "fromList [1" ++ concat (replicate value ",1") ++ "]"--mkListString :: Int -> String-mkListString value = "[1" ++ concat (replicate value ",1") ++ "]"--mkList :: Int -> [Int]-mkList value = [1..value]--defaultStreamSize :: Int-defaultStreamSize = 100000--main :: IO ()-main = do- -- XXX Fix indentation- (value, cfg, benches) <- parseCLIOpts defaultStreamSize- let bufValue = min value defaultStreamSize- when (bufValue /= value) $- putStrLn $ "Limiting stream size to "- ++ show defaultStreamSize- ++ " for buffered operations"-- bufValue `seq` value `seq` runMode (mode cfg) cfg benches- [ bgroup "serially"- [ bgroup "pure"- [ benchPureSink value "id" id- , benchPureSink1 "eqBy" (Ops.eqByPure value)- , benchPureSink value "==" Ops.eqInstance- , benchPureSink value "/=" Ops.eqInstanceNotEq- , benchPureSink1 "cmpBy" (Ops.cmpByPure value)- , benchPureSink value "<" Ops.ordInstance- , benchPureSink value "min" Ops.ordInstanceMin- , benchPureSrc "IsList.fromList" (Ops.sourceIsList value)- -- length is used to check for foldr/build fusion- , benchPureSink value "length . IsList.toList" (length . GHC.toList)- , benchPureSrc "IsString.fromString" (Ops.sourceIsString value)- , benchPureSink value "showsPrec pure streams" Ops.showInstance- , benchPureSink value "foldl'" Ops.pureFoldl'- ]- , bgroup "foldable"- [ -- Foldable instance- -- type class operations- bench "foldl'" $ nf (Ops.foldableFoldl' value) 1- , bench "foldrElem" $ nf (Ops.foldableFoldrElem value) 1- -- , bench "null" $ nf (Ops.foldableNull value) 1- , bench "elem" $ nf (Ops.foldableElem value) 1- , bench "length" $ nf (Ops.foldableLength value) 1- , bench "sum" $ nf (Ops.foldableSum value) 1- , bench "product" $ nf (Ops.foldableProduct value) 1- , bench "minimum" $ nf (Ops.foldableMin value) 1- , bench "maximum" $ nf (Ops.foldableMax value) 1- , bench "length . toList" $- nf (length . Ops.foldableToList value) 1-- -- folds- , bench "notElem" $ nf (Ops.foldableNotElem value) 1- , bench "find" $ nf (Ops.foldableFind value) 1- , bench "all" $ nf (Ops.foldableAll value) 1- , bench "any" $ nf (Ops.foldableAny value) 1- , bench "and" $ nf (Ops.foldableAnd value) 1- , bench "or" $ nf (Ops.foldableOr value) 1-- -- Note: minimumBy/maximumBy do not work in constant memory they are in- -- the O(n) group of benchmarks down below in this file.-- -- Applicative and Traversable operations- -- TBD: traverse_- , benchIOSink1 "mapM_" (Ops.foldableMapM_ value)- -- TBD: for_- -- TBD: forM_- , benchIOSink1 "sequence_" (Ops.foldableSequence_ value)- -- TBD: sequenceA_- -- TBD: asum- -- , benchIOSink1 "msum" (Ops.foldableMsum value)- ]- , bgroup "generation"- [ -- Most basic, barely stream continuations running- benchIOSrc serially "unfoldr" (Ops.sourceUnfoldr value)- , benchIOSrc serially "unfoldrM" (Ops.sourceUnfoldrM value)- , benchIOSrc serially "intFromTo" (Ops.sourceIntFromTo value)- , benchIOSrc serially "intFromThenTo" (Ops.sourceIntFromThenTo value)- , benchIOSrc serially "integerFromStep" (Ops.sourceIntegerFromStep value)- , benchIOSrc serially "fracFromThenTo" (Ops.sourceFracFromThenTo value)- , benchIOSrc serially "fracFromTo" (Ops.sourceFracFromTo value)- , benchIOSrc serially "fromList" (Ops.sourceFromList value)- , benchIOSrc serially "fromListM" (Ops.sourceFromListM value)- -- These are essentially cons and consM- , benchIOSrc serially "fromFoldable" (Ops.sourceFromFoldable value)- , benchIOSrc serially "fromFoldableM" (Ops.sourceFromFoldableM value)- , benchIOSrc serially "currentTime/0.00001s"- $ Ops.currentTime value 0.00001- ]- , bgroup "elimination"- [ bgroup "reduce"- [ bgroup "IO"- [- benchIOSink value "foldl'" Ops.foldl'Reduce- , benchIOSink value "foldl1'" Ops.foldl1'Reduce- , benchIOSink value "foldlM'" Ops.foldlM'Reduce- ]- , bgroup "Identity"- [- benchIdentitySink value "foldl'" Ops.foldl'Reduce- , benchIdentitySink value "foldl1'" Ops.foldl1'Reduce- , benchIdentitySink value "foldlM'" Ops.foldlM'Reduce- ]- ]-- , bgroup "build"- [ bgroup "Identity"- [ benchIdentitySink value "foldrM" Ops.foldrMBuild- ]- ]- , benchIOSink value "uncons" Ops.uncons- , benchIOSink value "toNull" $ Ops.toNull serially- , benchIOSink value "mapM_" Ops.mapM_-- , benchIOSink value "init" Ops.init-- -- this is too low and causes all benchmarks reported in ns- -- , benchIOSink value "head" Ops.head- , benchIOSink value "last" Ops.last- -- , benchIOSink value "lookup" Ops.lookup- , benchIOSink value "find" (Ops.find value)- , benchIOSink value "findIndex" (Ops.findIndex value)- , benchIOSink value "elemIndex" (Ops.elemIndex value)-- -- this is too low and causes all benchmarks reported in ns- -- , benchIOSink value "null" Ops.null- , benchIOSink value "elem" (Ops.elem value)- , benchIOSink value "notElem" (Ops.notElem value)- , benchIOSink value "all" (Ops.all value)- , benchIOSink value "any" (Ops.any value)- , benchIOSink value "and" (Ops.and value)- , benchIOSink value "or" (Ops.or value)-- , benchIOSink value "length" Ops.length- , benchHoistSink value "length . generally" (Ops.length . IP.generally)- , benchIOSink value "sum" Ops.sum- , benchIOSink value "product" Ops.product-- , benchIOSink value "maximumBy" Ops.maximumBy- , benchIOSink value "maximum" Ops.maximum- , benchIOSink value "minimumBy" Ops.minimumBy- , benchIOSink value "minimum" Ops.minimum-- ]- , bgroup "folds"- [ benchIOSink value "drain" (S.fold FL.drain)- , benchIOSink value "drainN" (S.fold (IFL.drainN value))- , benchIOSink value "drainWhileTrue" (S.fold (IFL.drainWhile $ (<=) (value + 1)))- , benchIOSink value "drainWhileFalse" (S.fold (IFL.drainWhile $ (>=) (value + 1)))- , benchIOSink value "sink" (S.fold $ Sink.toFold Sink.drain)- , benchIOSink value "last" (S.fold FL.last)- , benchIOSink value "lastN.1" (S.fold (IA.lastN 1))- , benchIOSink value "lastN.10" (S.fold (IA.lastN 10))- , benchIOSink value "length" (S.fold FL.length)- , benchIOSink value "sum" (S.fold FL.sum)- , benchIOSink value "product" (S.fold FL.product)- , benchIOSink value "maximumBy" (S.fold (FL.maximumBy compare))- , benchIOSink value "maximum" (S.fold FL.maximum)- , benchIOSink value "minimumBy" (S.fold (FL.minimumBy compare))- , benchIOSink value "minimum" (S.fold FL.minimum)- , benchIOSink value "mean" (\s -> S.fold FL.mean (S.map (fromIntegral :: Int -> Double) s))- , benchIOSink value "variance" (\s -> S.fold FL.variance (S.map (fromIntegral :: Int -> Double) s))- , benchIOSink value "stdDev" (\s -> S.fold FL.stdDev (S.map (fromIntegral :: Int -> Double) s))-- , benchIOSink value "mconcat" (S.fold FL.mconcat . (S.map (Last . Just)))- , benchIOSink value "foldMap" (S.fold (FL.foldMap (Last . Just)))-- , benchIOSink value "index" (S.fold (FL.index (value + 1)))- , benchIOSink value "head" (S.fold FL.head)- , benchIOSink value "find" (S.fold (FL.find (== (value + 1))))- , benchIOSink value "findIndex" (S.fold (FL.findIndex (== (value + 1))))- , benchIOSink value "elemIndex" (S.fold (FL.elemIndex (value + 1)))-- , benchIOSink value "null" (S.fold FL.null)- , benchIOSink value "elem" (S.fold (FL.elem (value + 1)))- , benchIOSink value "notElem" (S.fold (FL.notElem (value + 1)))- , benchIOSink value "all" (S.fold (FL.all (<= (value + 1))))- , benchIOSink value "any" (S.fold (FL.any (> (value + 1))))- , benchIOSink value "and" (\s -> S.fold FL.and (S.map (<= (value + 1)) s))- , benchIOSink value "or" (\s -> S.fold FL.or (S.map (> (value + 1)) s))- ]- , bgroup "fold-multi-stream"- [ benchIOSink1 "eqBy" (Ops.eqBy value)- , benchIOSink1 "cmpBy" (Ops.cmpBy value)- , benchIOSink value "isPrefixOf" Ops.isPrefixOf- , benchIOSink value "isSubsequenceOf" Ops.isSubsequenceOf- , benchIOSink value "stripPrefix" Ops.stripPrefix- ]- , bgroup "folds-transforms"- [ benchIOSink value "drain" (S.fold FL.drain)- , benchIOSink value "lmap" (S.fold (IFL.lmap (+1) FL.drain))- , benchIOSink value "pipe-mapM"- (S.fold (IFL.transform (Pipe.mapM (\x -> return $ x + 1)) FL.drain))- ]- , bgroup "folds-compositions" -- Applicative- [- benchIOSink value "all,any" (S.fold ((,) <$> FL.all (<= (value + 1))- <*> FL.any (> (value + 1))))- , benchIOSink value "sum,length" (S.fold ((,) <$> FL.sum <*> FL.length))- ]- , bgroup "pipes"- [ benchIOSink value "mapM" (Ops.transformMapM serially 1)- , benchIOSink value "compose" (Ops.transformComposeMapM serially 1)- , benchIOSink value "tee" (Ops.transformTeeMapM serially 1)- , benchIOSink value "zip" (Ops.transformZipMapM serially 1)- ]- , bgroup "pipesX4"- [ benchIOSink value "mapM" (Ops.transformMapM serially 4)- , benchIOSink value "compose" (Ops.transformComposeMapM serially 4)- , benchIOSink value "tee" (Ops.transformTeeMapM serially 4)- , benchIOSink value "zip" (Ops.transformZipMapM serially 4)- ]- , bgroup "transformer"- [ benchIOSrc serially "evalState" (Ops.evalStateT value)- , benchIOSrc serially "withState" (Ops.withState value)- ]- , bgroup "transformation"- [ benchIOSink value "scanl" (Ops.scan 1)- , benchIOSink value "scanl1'" (Ops.scanl1' 1)- , benchIOSink value "map" (Ops.map 1)- , benchIOSink value "fmap" (Ops.fmap 1)- , benchIOSink value "mapM" (Ops.mapM serially 1)- , benchIOSink value "mapMaybe" (Ops.mapMaybe 1)- , benchIOSink value "mapMaybeM" (Ops.mapMaybeM 1)- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->- Ops.sequence serially (Ops.sourceUnfoldrMAction value n)- , benchIOSink value "findIndices" (Ops.findIndices value 1)- , benchIOSink value "elemIndices" (Ops.elemIndices value 1)- , benchIOSink value "foldrS" (Ops.foldrS 1)- , benchIOSink value "foldrSMap" (Ops.foldrSMap 1)- , benchIOSink value "foldrT" (Ops.foldrT 1)- , benchIOSink value "foldrTMap" (Ops.foldrTMap 1)- , benchIOSink value "tap" (Ops.tap 1)- , benchIOSink value "tapRate 1 second" (Ops.tapRate 1)- , benchIOSink value "pollCounts 1 second" (Ops.pollCounts 1)- , benchIOSink value "tapAsync" (Ops.tapAsync 1)- , benchIOSink value "tapAsyncS" (Ops.tapAsyncS 1)- ]- , bgroup "transformationX4"- [ benchIOSink value "scan" (Ops.scan 4)- , benchIOSink value "scanl1'" (Ops.scanl1' 4)- , benchIOSink value "map" (Ops.map 4)- , benchIOSink value "fmap" (Ops.fmap 4)- , benchIOSink value "mapM" (Ops.mapM serially 4)- , benchIOSink value "mapMaybe" (Ops.mapMaybe 4)- , benchIOSink value "mapMaybeM" (Ops.mapMaybeM 4)- -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->- -- Ops.sequence serially (Ops.sourceUnfoldrMAction n)- , benchIOSink value "findIndices" (Ops.findIndices value 4)- , benchIOSink value "elemIndices" (Ops.elemIndices value 4)- ]- , bgroup "filtering"- [ benchIOSink value "filter-even" (Ops.filterEven 1)- , benchIOSink value "filter-all-out" (Ops.filterAllOut value 1)- , benchIOSink value "filter-all-in" (Ops.filterAllIn value 1)-- , benchIOSink value "take-all" (Ops.takeAll value 1)- , benchIOSink value "takeByTime-all"- (Ops.takeByTime (NanoSecond64 maxBound) 1)- , benchIOSink value "takeWhile-true" (Ops.takeWhileTrue value 1)- --, benchIOSink value "takeWhileM-true" (Ops.takeWhileMTrue 1)-- -- "drop-one" is dual to "last"- , benchIOSink value "drop-one" (Ops.dropOne 1)- , benchIOSink value "drop-all" (Ops.dropAll value 1)- , benchIOSink value "dropByTime-all"- (Ops.dropByTime (NanoSecond64 maxBound) 1)- , benchIOSink value "dropWhile-true" (Ops.dropWhileTrue value 1)- --, benchIOSink value "dropWhileM-true" (Ops.dropWhileMTrue 1)- , benchIOSink value "dropWhile-false" (Ops.dropWhileFalse value 1)-- , benchIOSink value "deleteBy" (Ops.deleteBy value 1)- , benchIOSink value "intersperse" (Ops.intersperse value 1)- , benchIOSink value "insertBy" (Ops.insertBy value 1)- ]- , bgroup "filteringX4"- [ benchIOSink value "filter-even" (Ops.filterEven 4)- , benchIOSink value "filter-all-out" (Ops.filterAllOut value 4)- , benchIOSink value "filter-all-in" (Ops.filterAllIn value 4)- , benchIOSink value "take-all" (Ops.takeAll value 4)- , benchIOSink value "takeWhile-true" (Ops.takeWhileTrue value 4)- --, benchIOSink value "takeWhileM-true" (Ops.takeWhileMTrue 4)- , benchIOSink value "drop-one" (Ops.dropOne 4)- , benchIOSink value "drop-all" (Ops.dropAll value 4)- , benchIOSink value "dropWhile-true" (Ops.dropWhileTrue value 4)- --, benchIOSink value "dropWhileM-true" (Ops.dropWhileMTrue 4)- , benchIOSink value "dropWhile-false" (Ops.dropWhileFalse value 4)- , benchIOSink value "deleteBy" (Ops.deleteBy value 4)- , benchIOSink value "intersperse" (Ops.intersperse value 4)- , benchIOSink value "insertBy" (Ops.insertBy value 4)- ]- , bgroup "joining"- [ benchIOSrc1 "zip (2,x/2)" (Ops.zip (value `div` 2))- , benchIOSrc1 "zipM (2,x/2)" (Ops.zipM (value `div` 2))- , benchIOSrc1 "mergeBy (2,x/2)" (Ops.mergeBy (value `div` 2))- , benchIOSrc1 "serial (2,x/2)" (Ops.serial2 (value `div` 2))- , benchIOSrc1 "append (2,x/2)" (Ops.append2 (value `div` 2))- , benchIOSrc1 "serial (2,2,x/4)" (Ops.serial4 (value `div` 4))- , benchIOSrc1 "append (2,2,x/4)" (Ops.append4 (value `div` 4))- , benchIOSrc1 "wSerial (2,x/2)" (Ops.wSerial2 value)- , benchIOSrc1 "interleave (2,x/2)" (Ops.interleave2 value)- , benchIOSrc1 "roundRobin (2,x/2)" (Ops.roundRobin2 value)- ]- , bgroup "concat-foldable"- [ benchIOSrc serially "foldMapWith" (Ops.sourceFoldMapWith value)- , benchIOSrc serially "foldMapWithM" (Ops.sourceFoldMapWithM value)- , benchIOSrc serially "foldMapM" (Ops.sourceFoldMapM value)- , benchIOSrc serially "foldWithConcatMapId" (Ops.sourceConcatMapId value)- ]- , bgroup "concat-serial"- [ benchIOSrc1 "concatMapPure (2,x/2)" (Ops.concatMapPure 2 (value `div` 2))- , benchIOSrc1 "concatMap (2,x/2)" (Ops.concatMap 2 (value `div` 2))- , benchIOSrc1 "concatMap (x/2,2)" (Ops.concatMap (value `div` 2) 2)- , benchIOSrc1 "concatMapRepl (x/4,4)" (Ops.concatMapRepl4xN value)- , benchIOSrc1 "concatUnfoldRepl (x/4,4)" (Ops.concatUnfoldRepl4xN value)-- , benchIOSrc1 "concatMapWithSerial (2,x/2)"- (Ops.concatMapWithSerial 2 (value `div` 2))- , benchIOSrc1 "concatMapWithSerial (x/2,2)"- (Ops.concatMapWithSerial (value `div` 2) 2)-- , benchIOSrc1 "concatMapWithAppend (2,x/2)"- (Ops.concatMapWithAppend 2 (value `div` 2))- ]- , bgroup "concat-interleave"- [ benchIOSrc1 "concatMapWithWSerial (2,x/2)"- (Ops.concatMapWithWSerial 2 (value `div` 2))- , benchIOSrc1 "concatMapWithWSerial (x/2,2)"- (Ops.concatMapWithWSerial (value `div` 2) 2)- ]- -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl- -- library. If scan/fold followed by a map is efficient enough we may not- -- need monolithic implementations of these.- , bgroup "mixed"- [ benchIOSink value "scanl-map" (Ops.scanMap 1)- , benchIOSink value "foldl-map" Ops.foldl'ReduceMap- , benchIOSink value "sum-product-fold" Ops.sumProductFold- , benchIOSink value "sum-product-scan" Ops.sumProductScan- ]- , bgroup "mixedX4"- [ benchIOSink value "scan-map" (Ops.scanMap 4)- , benchIOSink value "drop-map" (Ops.dropMap 4)- , benchIOSink value "drop-scan" (Ops.dropScan 4)- , benchIOSink value "take-drop" (Ops.takeDrop value 4)- , benchIOSink value "take-scan" (Ops.takeScan value 4)- , benchIOSink value "take-map" (Ops.takeMap value 4)- , benchIOSink value "filter-drop" (Ops.filterDrop value 4)- , benchIOSink value "filter-take" (Ops.filterTake value 4)- , benchIOSink value "filter-scan" (Ops.filterScan 4)- , benchIOSink value "filter-scanl1" (Ops.filterScanl1 4)- , benchIOSink value "filter-map" (Ops.filterMap value 4)- ]- ]- , bgroup "wSerially"- [ bgroup "transformation"- [ benchIOSink value "fmap" $ Ops.fmap' wSerially 1- ]- ]- , bgroup "zipSerially"- [ bgroup "transformation"- [ benchIOSink value "fmap" $ Ops.fmap' zipSerially 1- ]- ]- -- Non-streaming operations. We keep these in a spearate group so that we- -- can run these conveniently with smaller stream size.- --- -- These are also the operations that programmers should be aware of and- -- should avoid using in a streaming application.-- -- XXX stack dominant (upto 1M), segregate?- , bgroup "iterated"- [ benchIOSrc serially "mapM" Ops.iterateMapM- , benchIOSrc serially "scan(1/100)" Ops.iterateScan- , benchIOSrc serially "scanl1(1/100)" Ops.iterateScanl1- , benchIOSrc serially "filterEven" Ops.iterateFilterEven- , benchIOSrc serially "takeAll" (Ops.iterateTakeAll value)- , benchIOSrc serially "dropOne" Ops.iterateDropOne- , benchIOSrc serially "dropWhileFalse" (Ops.iterateDropWhileFalse value)- , benchIOSrc serially "dropWhileTrue" (Ops.iterateDropWhileTrue value)- ]- , bgroup "buffered"- [ -- Inherently non-streaming operations-- -- Right folds for reducing are inherently non-streaming as the- -- expression needs to be fully built before it can be reduced.- -- XXX Stack dominant (up to 4MB), segregate?- benchIOSink bufValue "foldrM/reduce/IO" Ops.foldrMReduce- , benchIdentitySink bufValue "foldrM/reduce/Identity" Ops.foldrMReduce-- -- Left folds for building a structure are inherently non-streaming as- -- the structure cannot be lazily consumed until fully built.- , benchIOSink bufValue "foldl'/build/IO" Ops.foldl'Build- , benchIdentitySink bufValue "foldl'/build/Identity" Ops.foldl'Build- , benchIOSink bufValue "foldlM'/build/IO" Ops.foldlM'Build- , benchIdentitySink bufValue "foldlM'/build/Identity" Ops.foldlM'Build-- -- accumulation due to strictness of IO monad- -- XXX Stack dominant, segregate?- , benchIOSink bufValue "foldrM/build/IO" Ops.foldrMBuild- , benchPureSinkIO bufValue "traversable/mapM" Ops.traversableMapM-- -- Converting the stream to a list or pure stream- -- XXX Stack dominant, segregate?- , benchIOSink bufValue "toList" Ops.toList- , benchIOSink bufValue "toListRev" Ops.toListRev-- , benchIOSink bufValue "toStream" (S.fold IP.toStream)- , benchIOSink bufValue "toStreamRev" (S.fold IP.toStreamRev)-- , benchIOSink bufValue "folds/toList" (S.fold FL.toList)- , benchIOSink bufValue "folds/toListRevF" (S.fold IFL.toListRevF)-- -- Converting the stream to an array- , benchIOSink bufValue "folds/lastN.Max" (S.fold (IA.lastN (bufValue + 1)))- , benchIOSink bufValue "folds/writeN" (S.fold (A.writeN bufValue))-- -- Reversing/sorting a stream- , benchIOSink bufValue "reverse" (Ops.reverse 1)- , benchIOSink bufValue "reverse'" (Ops.reverse' 1)-- -- XXX the definitions of minimumBy and maximumBy in Data.Foldable use- -- foldl1 which does not work in constant memory for our implementation.- -- It works in constant memory for lists but even for lists it takes 15x- -- more time compared to our foldl' based implementation.- , bench "minimumBy" $ nf (flip Ops.foldableMinBy 1) value- , bench "maximumBy" $ nf (flip Ops.foldableMaxBy 1) value- , bench "minimumByList" $ nf (flip Ops.foldableListMinBy 1) value-- -- XXX can these be streaming? Can we have special read/show style type- -- classes supporting streaming?- , mkString bufValue `deepseq` (bench "readsPrec pure streams" $- nf Ops.readInstance (mkString bufValue))- , mkString bufValue `deepseq` (bench "readsPrec Haskell lists" $- nf Ops.readInstanceList (mkListString bufValue))- , mkList bufValue `deepseq` (bench "showPrec Haskell lists" $- nf Ops.showInstanceList (mkList bufValue))-- -- XXX streaming operations that can potentially be fixed-- -- XXX These consume a lot of stack, fix or segregate- , benchIOSink bufValue "tail" Ops.tail- , benchIOSink bufValue "nullHeadTail" Ops.nullHeadTail-- , benchIOSrc1 "concatUnfoldInterleaveRepl (x/4,4)"- (Ops.concatUnfoldInterleaveRepl4xN bufValue)- , benchIOSrc1 "concatUnfoldRoundrobinRepl (x/4,4)"- (Ops.concatUnfoldRoundrobinRepl4xN bufValue)- ]- , bgroup "traversable"- [ -- Traversable instance- benchPureSinkIO bufValue "traverse" Ops.traversableTraverse- , benchPureSinkIO bufValue "sequenceA" Ops.traversableSequenceA- , benchPureSinkIO bufValue "mapM" Ops.traversableMapM- , benchPureSinkIO bufValue "sequence" Ops.traversableSequence- ]- ]
− benchmark/LinearAsync.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.DeepSeq (NFData)--- import Data.Functor.Identity (Identity, runIdentity)-import System.Random (randomRIO)--import Common (parseCLIOpts)--import Streamly-import Gauge--import qualified Streamly.Benchmark.Prelude as Ops---- We need a monadic bind here to make sure that the function f does not get--- completely optimized out by the compiler in some cases.------ | Takes a fold method, and uses it with a default source.-{-# INLINE benchIO #-}-benchIO :: (IsStream t, NFData b) => Int -> String -> (t IO Int -> IO b) -> Benchmark-benchIO value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source value---- | Takes a source, and uses it with a default drain/fold method.-{-# INLINE benchSrcIO #-}-benchSrcIO- :: (t IO a -> SerialT IO a)- -> String- -> (Int -> t IO a)- -> Benchmark-benchSrcIO t name f- = bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f--{-# INLINE benchMonadicSrcIO #-}-benchMonadicSrcIO :: String -> (Int -> IO ()) -> Benchmark-benchMonadicSrcIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f--{--_benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark-_benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10)--}--defaultStreamSize :: Int-defaultStreamSize = 100000--main :: IO ()-main = do- -- XXX Fix indentation- (value, cfg, benches) <- parseCLIOpts defaultStreamSize- let value2 = round $ sqrt $ (fromIntegral value :: Double)- value2 `seq` value `seq` runMode (mode cfg) cfg benches- [ bgroup "asyncly"- [ benchSrcIO asyncly "unfoldr" (Ops.sourceUnfoldr value)- , benchSrcIO asyncly "unfoldrM" (Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "fromFoldable" (Ops.sourceFromFoldable value)- , benchSrcIO asyncly "fromFoldableM" (Ops.sourceFromFoldableM value)- , benchSrcIO asyncly "foldMapWith" (Ops.sourceFoldMapWith value)- , benchSrcIO asyncly "foldMapWithM" (Ops.sourceFoldMapWithM value)- , benchSrcIO asyncly "foldMapM" (Ops.sourceFoldMapM value)- , benchIO value "map" $ Ops.map' asyncly 1- , benchIO value "fmap" $ Ops.fmap' asyncly 1- , benchIO value "mapM" $ Ops.mapM asyncly 1- , benchSrcIO asyncly "unfoldrM maxThreads 1"- (maxThreads 1 . Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "unfoldrM maxBuffer 1 (x/10 ops)"- (maxBuffer 1 . Ops.sourceUnfoldrMN (value `div` 10))- , benchMonadicSrcIO "concatMapWith (2,x/2)"- (Ops.concatStreamsWith async 2 (value `div` 2))- , benchMonadicSrcIO "concatMapWith (sqrt x,sqrt x)"- (Ops.concatStreamsWith async value2 value2)- , benchMonadicSrcIO "concatMapWith (sqrt x * 2,sqrt x / 2)"- (Ops.concatStreamsWith async (value2 * 2) (value2 `div` 2))- ]- , bgroup "wAsyncly"- [ benchSrcIO wAsyncly "unfoldr" (Ops.sourceUnfoldr value)- , benchSrcIO wAsyncly "unfoldrM" (Ops.sourceUnfoldrM value)- , benchSrcIO wAsyncly "fromFoldable" (Ops.sourceFromFoldable value)- , benchSrcIO wAsyncly "fromFoldableM" (Ops.sourceFromFoldableM value)- , benchSrcIO wAsyncly "foldMapWith" (Ops.sourceFoldMapWith value)- , benchSrcIO wAsyncly "foldMapWithM" (Ops.sourceFoldMapWithM value)- , benchSrcIO wAsyncly "foldMapM" (Ops.sourceFoldMapM value)- , benchIO value "map" $ Ops.map' wAsyncly 1- , benchIO value "fmap" $ Ops.fmap' wAsyncly 1- , benchIO value "mapM" $ Ops.mapM wAsyncly 1- , benchSrcIO wAsyncly "unfoldrM maxThreads 1"- (maxThreads 1 . Ops.sourceUnfoldrM value)- , benchSrcIO wAsyncly "unfoldrM maxBuffer 1 (x/10 ops)"- (maxBuffer 1 . Ops.sourceUnfoldrMN (value `div` 10))- -- When we merge streams using wAsync the size of the queue increases- -- slowly because of the binary composition adding just one more item- -- to the work queue only after every scheduling pass through the- -- work queue.- --- -- We should see the memory consumption increasing slowly if these- -- benchmarks are left to run on infinite number of streams of infinite- -- sizes.- , benchMonadicSrcIO "concatMapWith (2,x/2)"- (Ops.concatStreamsWith wAsync 2 (value `div` 2))- , benchMonadicSrcIO "concatMapWith (sqrt x,sqrt x)"- (Ops.concatStreamsWith wAsync value2 value2)- , benchMonadicSrcIO "concatMapWith (sqrt x * 2,sqrt x / 2)"- (Ops.concatStreamsWith wAsync (value2 * 2) (value2 `div` 2))- ]- -- unfoldr and fromFoldable are always serial and therefore the same for- -- all stream types.- , bgroup "aheadly"- [ benchSrcIO aheadly "unfoldr" (Ops.sourceUnfoldr value)- , benchSrcIO aheadly "unfoldrM" (Ops.sourceUnfoldrM value)- , benchSrcIO aheadly "fromFoldableM" (Ops.sourceFromFoldableM value)- , benchSrcIO aheadly "foldMapWith" (Ops.sourceFoldMapWith value)- , benchSrcIO aheadly "foldMapWithM" (Ops.sourceFoldMapWithM value)- , benchSrcIO aheadly "foldMapM" (Ops.sourceFoldMapM value)- , benchIO value "map" $ Ops.map' aheadly 1- , benchIO value "fmap" $ Ops.fmap' aheadly 1- , benchIO value "mapM" $ Ops.mapM aheadly 1- , benchSrcIO aheadly "unfoldrM maxThreads 1"- (maxThreads 1 . Ops.sourceUnfoldrM value)- , benchSrcIO aheadly "unfoldrM maxBuffer 1 (x/10 ops)"- (maxBuffer 1 . Ops.sourceUnfoldrMN (value `div` 10))- , benchSrcIO aheadly "fromFoldable" (Ops.sourceFromFoldable value)- , benchMonadicSrcIO "concatMapWith (2,x/2)"- (Ops.concatStreamsWith ahead 2 (value `div` 2))- , benchMonadicSrcIO "concatMapWith (sqrt x,sqrt x)"- (Ops.concatStreamsWith ahead value2 value2)- , benchMonadicSrcIO "concatMapWith (sqrt x * 2,sqrt x / 2)"- (Ops.concatStreamsWith ahead (value2 * 2) (value2 `div` 2))- ]- , bgroup "zip"- [ benchSrcIO serially "zipAsync (2,x/2)" (Ops.zipAsync (value `div` 2))- , benchSrcIO serially "zipAsyncM (2,x/2)"- (Ops.zipAsyncM (value `div` 2))- , benchSrcIO serially "zipAsyncAp (2,x/2)"- (Ops.zipAsyncAp (value `div` 2))- , benchIO value "fmap zipAsyncly" $ Ops.fmap' zipAsyncly 1- , benchSrcIO serially "mergeAsyncBy (2,x/2)"- (Ops.mergeAsyncBy (value `div` 2))- , benchSrcIO serially "mergeAsyncByM (2,x/2)"- (Ops.mergeAsyncByM (value `div` 2))- -- Parallel stages in a pipeline- , benchIO value "parAppMap" Ops.parAppMap- , benchIO value "parAppSum" Ops.parAppSum- ]- ]
− benchmark/LinearRate.hs
@@ -1,68 +0,0 @@--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com---- Rate benchmarks are kept separate because they need more running time to--- provide stable results.---- import Data.Functor.Identity (Identity, runIdentity)-import System.Random (randomRIO)--import Common (parseCLIOpts)--import Streamly-import Gauge--import qualified Streamly.Benchmark.Prelude as Ops---- | Takes a source, and uses it with a default drain/fold method.-{-# INLINE benchSrcIO #-}-benchSrcIO- :: (t IO Int -> SerialT IO Int)- -> String- -> (Int -> t IO Int)- -> Benchmark-benchSrcIO t name f- = bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f--{--_benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark-_benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10)--}--defaultStreamSize :: Int-defaultStreamSize = 100000--main :: IO ()-main = do- -- XXX Fix indentation- (value, cfg, benches) <- parseCLIOpts defaultStreamSize- value `seq` runMode (mode cfg) cfg benches- -- XXX arbitrarily large rate should be the same as rate Nothing- [ bgroup "avgrate"- [ bgroup "asyncly"- [ -- benchIO "unfoldr" $ Ops.toNull asyncly- benchSrcIO asyncly "unfoldrM" (Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "unfoldrM/Nothing"- (rate Nothing . Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "unfoldrM/1,000,000"- (avgRate 1000000 . Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "unfoldrM/3,000,000"- (avgRate 3000000 . Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "unfoldrM/10,000,000/maxThreads1"- (maxThreads 1 . avgRate 10000000 . Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "unfoldrM/10,000,000"- (avgRate 10000000 . Ops.sourceUnfoldrM value)- , benchSrcIO asyncly "unfoldrM/20,000,000"- (avgRate 20000000 . Ops.sourceUnfoldrM value)- ]- , bgroup "aheadly"- [- benchSrcIO aheadly "unfoldrM/1,000,000"- (avgRate 1000000 . Ops.sourceUnfoldrM value)- ]- ]- ]
− benchmark/Nested.hs
@@ -1,61 +0,0 @@--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.DeepSeq (NFData)-import Data.Functor.Identity (Identity, runIdentity)-import System.Random (randomRIO)--import Common (parseCLIOpts)--import Streamly-import Gauge--import qualified NestedOps as Ops--benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark-benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f--_benchId :: (NFData b) => String -> (Int -> Identity b) -> Benchmark-_benchId name f = bench name $ nf (\g -> runIdentity (g 1)) f--defaultStreamSize :: Int-defaultStreamSize = 100000--main :: IO ()-main = do- -- XXX Fix indentation- (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize- linearCount `seq` runMode (mode cfg) cfg benches- [ bgroup "serially"- [ benchIO "toNullAp" $ Ops.toNullAp linearCount serially- , benchIO "toNull" $ Ops.toNull linearCount serially- , benchIO "toNull3" $ Ops.toNull3 linearCount serially- -- , benchIO "toList" $ Ops.toList linearCount serially- -- XXX takes too much stack space- , benchIO "toListSome" $ Ops.toListSome linearCount serially- , benchIO "filterAllOut" $ Ops.filterAllOut linearCount serially- , benchIO "filterAllIn" $ Ops.filterAllIn linearCount serially- , benchIO "filterSome" $ Ops.filterSome linearCount serially- , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount serially- ]-- , bgroup "wSerially"- [ benchIO "toNullAp" $ Ops.toNullAp linearCount wSerially- , benchIO "toNull" $ Ops.toNull linearCount wSerially- , benchIO "toNull3" $ Ops.toNull3 linearCount wSerially- -- , benchIO "toList" $ Ops.toList linearCount wSerially- , benchIO "toListSome" $ Ops.toListSome linearCount wSerially- , benchIO "filterAllOut" $ Ops.filterAllOut linearCount wSerially- , benchIO "filterAllIn" $ Ops.filterAllIn linearCount wSerially- , benchIO "filterSome" $ Ops.filterSome linearCount wSerially- , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount wSerially- ]-- , bgroup "zipSerially"- [ benchIO "toNullAp" $ Ops.toNullAp linearCount zipSerially- ]- ]
− benchmark/NestedConcurrent.hs
@@ -1,84 +0,0 @@--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.DeepSeq (NFData)-import Control.Monad (when)-import Data.Functor.Identity (Identity, runIdentity)-import System.Random (randomRIO)--import Common (parseCLIOpts)--import Streamly-import Gauge--import qualified NestedOps as Ops--benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark-benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f--_benchId :: (NFData b) => String -> (Int -> Identity b) -> Benchmark-_benchId name f = bench name $ nf (\g -> runIdentity (g 1)) f--defaultStreamSize :: Int-defaultStreamSize = 100000--main :: IO ()-main = do- -- XXX Fix indentation- (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize- let finiteCount = min linearCount defaultStreamSize- when (finiteCount /= linearCount) $- putStrLn $ "Limiting stream size to "- ++ show defaultStreamSize- ++ " for finite stream operations only"-- finiteCount `seq` linearCount `seq` runMode (mode cfg) cfg benches- [- bgroup "aheadly"- [ benchIO "toNullAp" $ Ops.toNullAp linearCount aheadly- , benchIO "toNull" $ Ops.toNull linearCount aheadly- , benchIO "toNull3" $ Ops.toNull3 linearCount aheadly- -- , benchIO "toList" $ Ops.toList linearCount aheadly- -- XXX consumes too much stack space- , benchIO "toListSome" $ Ops.toListSome linearCount aheadly- , benchIO "filterAllOut" $ Ops.filterAllOut linearCount aheadly- , benchIO "filterAllIn" $ Ops.filterAllIn linearCount aheadly- , benchIO "filterSome" $ Ops.filterSome linearCount aheadly- , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount aheadly- ]-- , bgroup "asyncly"- [ benchIO "toNullAp" $ Ops.toNullAp linearCount asyncly- , benchIO "toNull" $ Ops.toNull linearCount asyncly- , benchIO "toNull3" $ Ops.toNull3 linearCount asyncly- -- , benchIO "toList" $ Ops.toList linearCount asyncly- , benchIO "toListSome" $ Ops.toListSome linearCount asyncly- , benchIO "filterAllOut" $ Ops.filterAllOut linearCount asyncly- , benchIO "filterAllIn" $ Ops.filterAllIn linearCount asyncly- , benchIO "filterSome" $ Ops.filterSome linearCount asyncly- , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount asyncly- ]-- , bgroup "zipAsyncly"- [ benchIO "toNullAp" $ Ops.toNullAp linearCount zipAsyncly- ]-- -- Operations that are not scalable to infinite streams- , bgroup "finite"- [ bgroup "wAsyncly"- [ benchIO "toNullAp" $ Ops.toNullAp finiteCount wAsyncly- , benchIO "toNull" $ Ops.toNull finiteCount wAsyncly- , benchIO "toNull3" $ Ops.toNull3 finiteCount wAsyncly- -- , benchIO "toList" $ Ops.toList finiteCount wAsyncly- , benchIO "toListSome" $ Ops.toListSome finiteCount wAsyncly- , benchIO "filterAllOut" $ Ops.filterAllOut finiteCount wAsyncly- -- , benchIO "filterAllIn" $ Ops.filterAllIn finiteCount wAsyncly- , benchIO "filterSome" $ Ops.filterSome finiteCount wAsyncly- , benchIO "breakAfterSome" $ Ops.breakAfterSome finiteCount wAsyncly- ]- ]- ]
− benchmark/NestedOps.hs
@@ -1,174 +0,0 @@--- |--- Module : BenchmarkOps--- Copyright : (c) 2018 Harendra Kumar------ License : MIT--- Maintainer : streamly@composewell.com--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module NestedOps where--import Control.Exception (try)-import GHC.Exception (ErrorCall)--import qualified Streamly as S hiding (runStream)-import qualified Streamly.Prelude as S------------------------------------------------------------------------------------ Stream generation and elimination----------------------------------------------------------------------------------type Stream m a = S.SerialT m a--{-# INLINE source #-}-source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-source = sourceUnfoldrM---- Change this to "sourceUnfoldrM value n" for consistency-{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceUnfoldrM n value = S.serially $ S.unfoldrM step n- where- step cnt =- if cnt > n + value- then return Nothing- else return (Just (cnt, cnt + 1))--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceUnfoldr start n = S.unfoldr step start- where- step cnt =- if cnt > start + n- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--{-# INLINE runToList #-}-runToList :: Monad m => Stream m a -> m [a]-runToList = S.toList------------------------------------------------------------------------------------ Benchmark ops----------------------------------------------------------------------------------{-# INLINE toNullAp #-}-toNullAp- :: (S.IsStream t, S.MonadAsync m, Applicative (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-toNullAp linearCount t start = runStream . t $- (+) <$> source start nestedCount2 <*> source start nestedCount2- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE toNull #-}-toNull- :: (S.IsStream t, S.MonadAsync m, Monad (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-toNull linearCount t start = runStream . t $ do- x <- source start nestedCount2- y <- source start nestedCount2- return $ x + y- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE toNull3 #-}-toNull3- :: (S.IsStream t, S.MonadAsync m, Monad (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-toNull3 linearCount t start = runStream . t $ do- x <- source start nestedCount3- y <- source start nestedCount3- z <- source start nestedCount3- return $ x + y + z- where- nestedCount3 = round (fromIntegral linearCount**(1/3::Double))--{-# INLINE toList #-}-toList- :: (S.IsStream t, S.MonadAsync m, Monad (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]-toList linearCount t start = runToList . t $ do- x <- source start nestedCount2- y <- source start nestedCount2- return $ x + y- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))---- Taking a specified number of elements is very expensive in logict so we have--- a test to measure the same.-{-# INLINE toListSome #-}-toListSome- :: (S.IsStream t, S.MonadAsync m, Monad (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]-toListSome linearCount t start =- runToList . t $ S.take 10000 $ do- x <- source start nestedCount2- y <- source start nestedCount2- return $ x + y- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE filterAllOut #-}-filterAllOut- :: (S.IsStream t, S.MonadAsync m, Monad (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-filterAllOut linearCount t start = runStream . t $ do- x <- source start nestedCount2- y <- source start nestedCount2- let s = x + y- if s < 0- then return s- else S.nil- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE filterAllIn #-}-filterAllIn- :: (S.IsStream t, S.MonadAsync m, Monad (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-filterAllIn linearCount t start = runStream . t $ do- x <- source start nestedCount2- y <- source start nestedCount2- let s = x + y- if s > 0- then return s- else S.nil- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE filterSome #-}-filterSome- :: (S.IsStream t, S.MonadAsync m, Monad (t m))- => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-filterSome linearCount t start = runStream . t $ do- x <- source start nestedCount2- y <- source start nestedCount2- let s = x + y- if s > 1100000- then return s- else S.nil- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE breakAfterSome #-}-breakAfterSome- :: (S.IsStream t, Monad (t IO))- => Int -> (t IO Int -> S.SerialT IO Int) -> Int -> IO ()-breakAfterSome linearCount t start = do- (_ :: Either ErrorCall ()) <- try $ runStream . t $ do- x <- source start nestedCount2- y <- source start nestedCount2- let s = x + y- if s > 1100000- then error "break"- else return s- return ()- where- nestedCount2 = round (fromIntegral linearCount**(1/2::Double))
− benchmark/NestedUnfold.hs
@@ -1,38 +0,0 @@--- |--- Module : NestedUnfold--- Copyright : (c) 2019 Composewell Technologies------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.DeepSeq (NFData)-import System.Random (randomRIO)--import Common (parseCLIOpts)--import qualified NestedUnfoldOps as Ops--import Gauge--benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark-benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f--defaultStreamSize :: Int-defaultStreamSize = 100000--main :: IO ()-main = do- (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize- linearCount `seq` runMode (mode cfg) cfg benches- [ bgroup "unfold"- [ benchIO "toNull" $ Ops.toNull linearCount- , benchIO "toNull3" $ Ops.toNull3 linearCount- , benchIO "concat" $ Ops.concat linearCount- -- , benchIO "toList" $ Ops.toList- , benchIO "toListSome" $ Ops.toListSome linearCount- , benchIO "filterAllOut" $ Ops.filterAllOut linearCount- , benchIO "filterAllIn" $ Ops.filterAllIn linearCount- , benchIO "filterSome" $ Ops.filterSome linearCount- , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount- ]- ]
− benchmark/NestedUnfoldOps.hs
@@ -1,126 +0,0 @@--- |--- Module : NestedUnfoldOps--- Copyright : (c) 2019 Composewell Technologies------ License : BSD3--- Maintainer : streamly@composewell.com--module NestedUnfoldOps where--import Control.Monad.IO.Class (MonadIO (..))-import Streamly.Internal.Data.Unfold (Unfold)--import qualified Streamly.Internal.Data.Unfold as UF-import qualified Streamly.Internal.Data.Fold as FL---- n * (n + 1) / 2 == linearCount-concatCount :: Int -> Int-concatCount linearCount =- round (((1 + 8 * fromIntegral linearCount)**(1/2::Double) - 1) / 2)---- double nested loop-nestedCount2 :: Int -> Int-nestedCount2 linearCount = round (fromIntegral linearCount**(1/2::Double))---- triple nested loop-nestedCount3 :: Int -> Int-nestedCount3 linearCount = round (fromIntegral linearCount**(1/3::Double))------------------------------------------------------------------------------------ Stream generation and elimination------------------------------------------------------------------------------------ generate numbers up to the argument value-{-# INLINE source #-}-source :: Monad m => Int -> Unfold m Int Int-source n = UF.enumerateFromToIntegral n------------------------------------------------------------------------------------ Benchmark ops----------------------------------------------------------------------------------{-# INLINE toNull #-}-toNull :: MonadIO m => Int -> Int -> m ()-toNull linearCount start = do- let end = start + nestedCount2 linearCount- UF.fold- (UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end))- FL.drain (start, start)--{-# INLINE toNull3 #-}-toNull3 :: MonadIO m => Int -> Int -> m ()-toNull3 linearCount start = do- let end = start + nestedCount3 linearCount- UF.fold- (UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end)- ((UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end))))- FL.drain (start, (start, start))--{-# INLINE concat #-}-concat :: MonadIO m => Int -> Int -> m ()-concat linearCount start = do- let end = start + concatCount linearCount- UF.fold- (UF.concat (source end) (source end))- FL.drain start--{-# INLINE toList #-}-toList :: MonadIO m => Int -> Int -> m [Int]-toList linearCount start = do- let end = start + nestedCount2 linearCount- UF.fold- (UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end))- FL.toList (start, start)--{-# INLINE toListSome #-}-toListSome :: MonadIO m => Int -> Int -> m [Int]-toListSome linearCount start = do- let end = start + nestedCount2 linearCount- UF.fold- (UF.take 1000 $ (UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end)))- FL.toList (start, start)--{-# INLINE filterAllOut #-}-filterAllOut :: MonadIO m => Int -> Int -> m ()-filterAllOut linearCount start = do- let end = start + nestedCount2 linearCount- UF.fold- (UF.filter (< 0)- $ UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end))- FL.drain (start, start)--{-# INLINE filterAllIn #-}-filterAllIn :: MonadIO m => Int -> Int -> m ()-filterAllIn linearCount start = do- let end = start + nestedCount2 linearCount- UF.fold- (UF.filter (> 0)- $ UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end))- FL.drain (start, start)--{-# INLINE filterSome #-}-filterSome :: MonadIO m => Int -> Int -> m ()-filterSome linearCount start = do- let end = start + nestedCount2 linearCount- UF.fold- (UF.filter (> 1100000)- $ UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end))- FL.drain (start, start)--{-# INLINE breakAfterSome #-}-breakAfterSome :: MonadIO m => Int -> Int -> m ()-breakAfterSome linearCount start = do- let end = start + nestedCount2 linearCount- UF.fold- (UF.takeWhile (<= 1100000)- $ UF.map (\(x, y) -> x + y)- $ UF.outerProduct (source end) (source end))- FL.drain (start, start)
− benchmark/Parallel.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Main--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--import Control.DeepSeq (NFData)--- import Data.Functor.Identity (Identity, runIdentity)-import System.Random (randomRIO)--import Common (parseCLIOpts)--import Streamly-import Gauge--import qualified Streamly.Benchmark.Prelude as Ops-import qualified NestedOps as Nested--{-# INLINE benchIONested #-}-benchIONested :: (NFData b) => String -> (Int -> IO b) -> Benchmark-benchIONested name f = bench name $ nfIO $ randomRIO (1,1) >>= f---- We need a monadic bind here to make sure that the function f does not get--- completely optimized out by the compiler in some cases.------ | Takes a fold method, and uses it with a default source.-{-# INLINE benchIO #-}-benchIO :: (IsStream t, NFData b) => Int -> String -> (t IO Int -> IO b) -> Benchmark-benchIO value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source value---- | Takes a source, and uses it with a default drain/fold method.-{-# INLINE benchSrcIO #-}-benchSrcIO- :: (t IO Int -> SerialT IO Int)- -> String- -> (Int -> t IO Int)- -> Benchmark-benchSrcIO t name f- = bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f--defaultStreamSize :: Int-defaultStreamSize = 100000--linear :: Int -> Int -> [Benchmark]-linear value value2 =- [ -- unfoldr is pure and works serially irrespective of the stream type- benchSrcIO parallely "unfoldr" (Ops.sourceUnfoldr value)- , benchSrcIO parallely "unfoldrM" (Ops.sourceUnfoldrM value)- , benchSrcIO parallely "fromFoldable" (Ops.sourceFromFoldable value)- , benchSrcIO parallely "fromFoldableM" (Ops.sourceFromFoldableM value)- , benchSrcIO parallely "foldMapWith" (Ops.sourceFoldMapWith value)- , benchSrcIO parallely "foldMapWithM" (Ops.sourceFoldMapWithM value)- , benchSrcIO parallely "foldMapM" (Ops.sourceFoldMapM value)- -- map/fmap are pure and therefore no concurrency would be added on top- -- of what the source stream (i.e. unfoldrM) provides.- , benchIO value "map" $ Ops.map' parallely 1- , benchIO value "fmap" $ Ops.fmap' parallely 1- , benchIO value "mapM" $ Ops.mapM parallely 1- , benchIONested "concatMapWith (2,x/2)"- (Ops.concatStreamsWith parallel 2 (value `div` 2))- , benchIONested "concatMapWith (sqrt x,sqrt x)"- (Ops.concatStreamsWith parallel value2 value2)- , benchIONested "concatMapWith (sqrt x * 2,sqrt x / 2)"- (Ops.concatStreamsWith parallel (value2 * 2) (value2 `div` 2))- ]--nested :: Int -> [Benchmark]-nested value =- [ benchIONested "toNullAp" $ Nested.toNullAp value parallely- , benchIONested "toNull" $ Nested.toNull value parallely- , benchIONested "toNull3" $ Nested.toNull3 value parallely- -- , benchIO "toList" $ Ops.toList value parallely- -- XXX fix thread blocked indefinitely in MVar- -- , benchIO "toListSome" $ Ops.toListSome value parallely- , benchIONested "filterAllOut" $ Nested.filterAllOut value parallely- , benchIONested "filterAllIn" $ Nested.filterAllIn value parallely- , benchIONested "filterSome" $ Nested.filterSome value parallely- , benchIONested "breakAfterSome" $ Nested.breakAfterSome value parallely- ]--main :: IO ()-main = do- (value, cfg, benches) <- parseCLIOpts defaultStreamSize- let value2 = round $ sqrt $ (fromIntegral value :: Double)- value2 `seq` value `seq`- runMode (mode cfg) cfg benches $- [ bgroup "parallelly"- [ bgroup "linear" $ linear value value2- , bgroup "nested" $ nested value- ]- ]
+ benchmark/README.md view
@@ -0,0 +1,102 @@+## Running Benchmarks++`bench.sh` script at the root of the repo is the top level driver for running+benchmarks. It runs the requested benchmarks and then creates a report from the+results using the `bench-show` package. Try `bench.sh --help` for available+options to run it.++## Quick start++Run these commands from the root of the repo.++To run the default benchmarks:++```+$ ./bench.sh+```++To run all benchmarks:++```+$ ./bench.sh --benchmarks all+```++To run `linear` and `linear-async` benchmarks:++```+$ ./bench.sh --benchmarks "linear linear-async"+```++To run only the base benchmark and only the benchmarks prefixed with+`StreamD` in that (anything after a `--` is passed to gauge):++```+$ ./bench.sh --benchmarks base -- StreamD+```++## Comparing benchmarks++To compare two sets of results, first run the benchmarks at the baseline+commit:++```+$ ./bench.sh+```++And then run with the `--append` option at the commit that you want to compare+with the baseline. It will show the comparison with the baseline:++```+$ ./bench.sh --append+```++Append just adds the next set of results in the same results file. You can keep+appending more results and all of them will be compared with the baseline.++You can use `--compare` to compare the previous commit with the head commit:++```+$ ./bench.sh --compare+```++To compare the head commit with some other base commit:++```+$ ./bench.sh --compare --base d918833+```++To compare two arbitrary commits:++```+$ ./bench.sh --compare --base d918833 --candidate 38aa5f2+```++Note that the above may not always work because the script and the benchmarks+themselves might have changed across the commits. The `--append` method is more+reliable to compare.++## Available Benchmarks++The benchmark names that you can use when running `bench.sh`:++* `base`: a benchmark that measures the raw operations of the basic streams+ `StreamD` and `StreamK`.++* `linear`: measures the non-monadic operations of serial streams+* `linear-async`: measures the non-monadic operations of concurrent streams+* `linear-rate`: measures the rate limiting operations+* `nested`: measures the monadic operations of all streams+* `all`: runs all of the above benchmarks++## Reporting without measuring++You can use the `--no-measure` option to report the already measured results in+the benchmarks results file. A results file may collect an arbitrary number of+results by running with `--append` multiple times. Each benchmark has its own+results file, for example the `linear` benchmark has the results file at+`charts/linear/results.csv`.++You can also manually edit the file to remove a set of results if you like or+to append results from previously saved results or from some other results+file. After editing you can run `bench.sh` with the `--no-measure` option to+see the reports corresponding to the results.
− benchmark/StreamDKOps.hs
@@ -1,423 +0,0 @@--- |--- Module : StreamDKOps--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module StreamDKOps where---- import Control.Monad (when)--- import Data.Maybe (isJust)-import Prelude- (Monad, Int, (+), (.), return, undefined, Maybe(..), round, (/),- (**), (>))-import qualified Prelude as P--- import qualified Data.List as List--import qualified Streamly.Internal.Data.Stream.StreamDK as S--- import qualified Streamly.Internal.Data.Stream.Prelude as SP--- import qualified Streamly.Internal.Data.SVar as S--value, value2, value3, value16, maxValue :: Int-value = 100000-value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop-value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop-value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop-maxValue = value------------------------------------------------------------------------------------ Benchmark ops-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Stream generation and elimination----------------------------------------------------------------------------------type Stream m a = S.Stream m a--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: Monad m => Int -> Stream m Int-sourceUnfoldr n = S.unfoldr step n- where- step cnt =- if cnt > n + value- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrN #-}-sourceUnfoldrN :: Monad m => Int -> Int -> Stream m Int-sourceUnfoldrN m n = S.unfoldr step n- where- step cnt =- if cnt > n + m- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: Monad m => Int -> Stream m Int-sourceUnfoldrM n = S.unfoldrM step n- where- step cnt =- if cnt > n + value- then return Nothing- else return (Just (cnt, cnt + 1))--{-# INLINE sourceUnfoldrMN #-}-sourceUnfoldrMN :: Monad m => Int -> Int -> Stream m Int-sourceUnfoldrMN m n = S.unfoldrM step n- where- step cnt =- if cnt > n + m- then return Nothing- else return (Just (cnt, cnt + 1))--{--{-# INLINE sourceFromEnum #-}-sourceFromEnum :: Monad m => Int -> Stream m Int-sourceFromEnum n = S.enumFromStepN n 1 value--}--{--{-# INLINE sourceFromFoldable #-}-sourceFromFoldable :: Int -> Stream m Int-sourceFromFoldable n = S.fromFoldable [n..n+value]--}--{--{-# INLINE sourceFromFoldableM #-}-sourceFromFoldableM :: S.MonadAsync m => Int -> Stream m Int-sourceFromFoldableM n = S.fromFoldableM (Prelude.fmap return [n..n+value])--}--{--{-# INLINE sourceFoldMapWith #-}-sourceFoldMapWith :: Int -> Stream m Int-sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]--{-# INLINE sourceFoldMapWithM #-}-sourceFoldMapWithM :: Monad m => Int -> Stream m Int-sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]--}--{-# INLINE source #-}-source :: Monad m => Int -> Stream m Int-source = sourceUnfoldrM------------------------------------------------------------------------------------ Elimination----------------------------------------------------------------------------------{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--- runStream = S.mapM_ (\_ -> return ())--{--{-# INLINE mapM_ #-}-mapM_ :: Monad m => Stream m a -> m ()-mapM_ = S.mapM_ (\_ -> return ())--}--{-# INLINE toNull #-}-toNull :: Monad m => Stream m Int -> m ()-toNull = runStream--{-# INLINE uncons #-}-uncons :: Monad m => Stream m Int -> m ()-uncons s = do- r <- S.uncons s- case r of- Nothing -> return ()- Just (_, t) -> uncons t--{--{-# INLINE init #-}-init :: (Monad m, S.IsStream t) => t m a -> m ()-init s = do- t <- S.init s- P.mapM_ S.drain t--{-# INLINE tail #-}-tail :: (Monad m, S.IsStream t) => t m a -> m ()-tail s = S.tail s >>= P.mapM_ tail--{-# INLINE nullTail #-}-{-# INLINE headTail #-}-{-# INLINE zip #-}-nullTail, headTail, zip- :: Monad m- => Stream m Int -> m ()--nullTail s = do- r <- S.null s- when (not r) $ S.tail s >>= P.mapM_ nullTail--headTail s = do- h <- S.head s- when (isJust h) $ S.tail s >>= P.mapM_ headTail--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]-toList = S.toList--{-# INLINE foldl #-}-foldl :: Monad m => Stream m Int -> m Int-foldl = S.foldl' (+) 0--{-# INLINE last #-}-last :: Monad m => Stream m Int -> m (Maybe Int)-last = S.last--}------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{-# INLINE transform #-}-transform :: Monad m => Stream m a -> m ()-transform = runStream--{-# INLINE composeN #-}-composeN- :: Monad m- => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()-composeN n f =- case n of- 1 -> transform . f- 2 -> transform . f . f- 3 -> transform . f . f . f- 4 -> transform . f . f . f . f- _ -> undefined--{--{-# INLINE scan #-}-{-# INLINE map #-}-{-# INLINE fmap #-}-{-# INLINE filterEven #-}-{-# INLINE filterAllOut #-}-{-# INLINE filterAllIn #-}-{-# INLINE takeOne #-}-{-# INLINE takeAll #-}-{-# INLINE takeWhileTrue #-}-{-# INLINE dropOne #-}-{-# INLINE dropAll #-}-{-# INLINE dropWhileTrue #-}-{-# INLINE dropWhileFalse #-}-{-# INLINE foldlS #-}-{-# INLINE concatMap #-}-scan, map, fmap, filterEven, filterAllOut,- filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropOne,- dropWhileTrue, dropWhileFalse, foldlS, concatMap- :: Monad m- => Int -> Stream m Int -> m ()--{-# INLINE mapM #-}-{-# INLINE mapMSerial #-}-{-# INLINE intersperse #-}-mapM, mapMSerial, intersperse- :: S.MonadAsync m => Int -> Stream m Int -> m ()--scan n = composeN n $ S.scanl' (+) 0-map n = composeN n $ P.fmap (+1)-fmap n = composeN n $ P.fmap (+1)-mapM n = composeN n $ S.mapM return-mapMSerial n = composeN n $ S.mapMSerial return-filterEven n = composeN n $ S.filter even-filterAllOut n = composeN n $ S.filter (> maxValue)-filterAllIn n = composeN n $ S.filter (<= maxValue)-takeOne n = composeN n $ S.take 1-takeAll n = composeN n $ S.take maxValue-takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)-dropOne n = composeN n $ S.drop 1-dropAll n = composeN n $ S.drop maxValue-dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)-dropWhileFalse n = composeN n $ S.dropWhile (<= 1)-foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil--- We use a (sqrt n) element stream as source and then concat the same stream--- for each element to produce an n element stream.-concatMap n = composeN n $ (\s -> S.concatMap (\_ -> s) s)-intersperse n = composeN n $ S.intersperse maxValue------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource- :: S.MonadAsync m- => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)- where- f (0 :: Int) m = g m- f x m = g (f (x P.- 1) m)--{-# INLINE iterateMapM #-}-{-# INLINE iterateScan #-}-{-# INLINE iterateFilterEven #-}-{-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,- iterateDropWhileFalse, iterateDropWhileTrue- :: S.MonadAsync m- => Int -> Stream m Int---- this is quadratic-iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)-iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))- (maxIters `div` 10)--iterateMapM = iterateSource (S.mapM return) maxIters-iterateFilterEven = iterateSource (S.filter even) maxIters-iterateTakeAll = iterateSource (S.take maxValue) maxIters-iterateDropOne = iterateSource (S.drop 1) maxIters-iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters------------------------------------------------------------------------------------ Zipping and concat----------------------------------------------------------------------------------zip src = transform $ S.zipWith (,) src src--{-# INLINE concatMapRepl4xN #-}-concatMapRepl4xN :: Monad m => Stream m Int -> m ()-concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)------------------------------------------------------------------------------------ Mixed Composition----------------------------------------------------------------------------------{-# INLINE scanMap #-}-{-# INLINE dropMap #-}-{-# INLINE dropScan #-}-{-# INLINE takeDrop #-}-{-# INLINE takeScan #-}-{-# INLINE takeMap #-}-{-# INLINE filterDrop #-}-{-# INLINE filterTake #-}-{-# INLINE filterScan #-}-{-# INLINE filterMap #-}-scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,- filterTake, filterScan, filterMap- :: Monad m => Int -> Stream m Int -> m ()--scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop n = composeN n $ S.drop 1 . S.take maxValue-takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue-takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue-filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)-filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)------------------------------------------------------------------------------------ Nested Composition----------------------------------------------------------------------------------{-# INLINE toNullApNested #-}-toNullApNested :: Monad m => Stream m Int -> m ()-toNullApNested s = runStream $ do- (+) <$> s <*> s--{-# INLINE toNullNested #-}-toNullNested :: Monad m => Stream m Int -> m ()-toNullNested s = runStream $ do- x <- s- y <- s- return $ x + y--{-# INLINE toNullNested3 #-}-toNullNested3 :: Monad m => Stream m Int -> m ()-toNullNested3 s = runStream $ do- x <- s- y <- s- z <- s- return $ x + y + z--{-# INLINE filterAllOutNested #-}-filterAllOutNested- :: Monad m- => Stream m Int -> m ()-filterAllOutNested str = runStream $ do- x <- str- y <- str- let s = x + y- if s < 0- then return s- else S.nil--{-# INLINE filterAllInNested #-}-filterAllInNested- :: Monad m- => Stream m Int -> m ()-filterAllInNested str = runStream $ do- x <- str- y <- str- let s = x + y- if s > 0- then return s- else S.nil------------------------------------------------------------------------------------ Nested Composition Pure lists----------------------------------------------------------------------------------{-# INLINE sourceUnfoldrList #-}-sourceUnfoldrList :: Int -> Int -> [Int]-sourceUnfoldrList maxval n = List.unfoldr step n- where- step cnt =- if cnt > n + maxval- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE toNullApNestedList #-}-toNullApNestedList :: [Int] -> [Int]-toNullApNestedList s = (+) <$> s <*> s--{-# INLINE toNullNestedList #-}-toNullNestedList :: [Int] -> [Int]-toNullNestedList s = do- x <- s- y <- s- return $ x + y--{-# INLINE toNullNestedList3 #-}-toNullNestedList3 :: [Int] -> [Int]-toNullNestedList3 s = do- x <- s- y <- s- z <- s- return $ x + y + z--{-# INLINE filterAllOutNestedList #-}-filterAllOutNestedList :: [Int] -> [Int]-filterAllOutNestedList str = do- x <- str- y <- str- let s = x + y- if s < 0- then return s- else []--{-# INLINE filterAllInNestedList #-}-filterAllInNestedList :: [Int] -> [Int]-filterAllInNestedList str = do- x <- str- y <- str- let s = x + y- if s > 0- then return s- else []--}
− benchmark/StreamDOps.hs
@@ -1,357 +0,0 @@--- |--- Module : StreamDOps--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module StreamDOps where--import Control.Monad (when)-import Data.Maybe (isJust)-import Prelude- (Monad, Int, (+), ($), (.), return, (>), even, (<=), div,- subtract, undefined, Maybe(..), not, (>>=),- maxBound, fmap, odd, (==), flip, (<$>), (<*>), round, (/), (**), (<))-import qualified Prelude as P--import qualified Streamly.Internal.Data.Stream.StreamD as S-import qualified Streamly.Internal.Data.Unfold as UF---- We try to keep the total number of iterations same irrespective of nesting--- of the loops so that the overhead is easy to compare.-value, value2, value3, value16, maxValue :: Int-value = 100000-value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop-value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop-value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop-maxValue = value------------------------------------------------------------------------------------ Stream generation and elimination----------------------------------------------------------------------------------type Stream m a = S.Stream m a--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: Monad m => Int -> Stream m Int-sourceUnfoldr n = S.unfoldr step n- where- step cnt =- if cnt > n + value- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrN #-}-sourceUnfoldrN :: Monad m => Int -> Int -> Stream m Int-sourceUnfoldrN m n = S.unfoldr step n- where- step cnt =- if cnt > n + m- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrMN #-}-sourceUnfoldrMN :: Monad m => Int -> Int -> Stream m Int-sourceUnfoldrMN m n = S.unfoldrM step n- where- step cnt =- if cnt > n + m- then return Nothing- else return (Just (cnt, cnt + 1))--{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: Monad m => Int -> Stream m Int-sourceUnfoldrM n = S.unfoldrM step n- where- step cnt =- if cnt > n + value- then return Nothing- else return (Just (cnt, cnt + 1))--{-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: Monad m => Int -> Stream m Int-sourceIntFromTo n = S.enumerateFromToIntegral n (n + value)--{-# INLINE sourceFromList #-}-sourceFromList :: Monad m => Int -> Stream m Int-sourceFromList n = S.fromList [n..n+value]--{-# INLINE source #-}-source :: Monad m => Int -> Stream m Int-source = sourceUnfoldrM------------------------------------------------------------------------------------ Elimination----------------------------------------------------------------------------------{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--{-# INLINE mapM_ #-}-mapM_ :: Monad m => Stream m a -> m ()-mapM_ = S.mapM_ (\_ -> return ())--{-# INLINE toNull #-}-toNull :: Monad m => Stream m Int -> m ()-toNull = runStream--{-# INLINE uncons #-}-{-# INLINE nullTail #-}-{-# INLINE headTail #-}-uncons, nullTail, headTail- :: Monad m- => Stream m Int -> m ()--uncons s = do- r <- S.uncons s- case r of- Nothing -> return ()- Just (_, t) -> uncons t--{-# INLINE tail #-}-tail :: Monad m => Stream m a -> m ()-tail s = S.tail s >>= P.mapM_ tail--nullTail s = do- r <- S.null s- when (not r) $ S.tail s >>= P.mapM_ nullTail--headTail s = do- h <- S.head s- when (isJust h) $ S.tail s >>= P.mapM_ headTail--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]-toList = S.toList--{-# INLINE foldl #-}-foldl :: Monad m => Stream m Int -> m Int-foldl = S.foldl' (+) 0--{-# INLINE last #-}-last :: Monad m => Stream m Int -> m (Maybe Int)-last = S.last------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{-# INLINE transform #-}-transform :: Monad m => Stream m a -> m ()-transform = runStream--{-# INLINE composeN #-}-composeN- :: Monad m- => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()-composeN n f =- case n of- 1 -> transform . f- 2 -> transform . f . f- 3 -> transform . f . f . f- 4 -> transform . f . f . f . f- _ -> undefined--{-# INLINE scan #-}-{-# INLINE map #-}-{-# INLINE fmap #-}-{-# INLINE mapM #-}-{-# INLINE mapMaybe #-}-{-# INLINE mapMaybeM #-}-{-# INLINE filterEven #-}-{-# INLINE filterAllOut #-}-{-# INLINE filterAllIn #-}-{-# INLINE takeOne #-}-{-# INLINE takeAll #-}-{-# INLINE takeWhileTrue #-}-{-# INLINE takeWhileMTrue #-}-{-# INLINE dropOne #-}-{-# INLINE dropAll #-}-{-# INLINE dropWhileTrue #-}-{-# INLINE dropWhileMTrue #-}-{-# INLINE dropWhileFalse #-}-{-# INLINE foldrS #-}-{-# INLINE foldlS #-}-{-# INLINE concatMap #-}-{-# INLINE intersperse #-}-scan, map, fmap, mapM, mapMaybe, mapMaybeM, filterEven, filterAllOut,- filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,- dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse, foldrS, foldlS,- concatMap, intersperse- :: Monad m- => Int -> Stream m Int -> m ()--scan n = composeN n $ S.scanl' (+) 0-fmap n = composeN n $ Prelude.fmap (+1)-map n = composeN n $ S.map (+1)-mapM n = composeN n $ S.mapM return-mapMaybe n = composeN n $ S.mapMaybe- (\x -> if Prelude.odd x then Nothing else Just x)-mapMaybeM n = composeN n $ S.mapMaybeM- (\x -> if Prelude.odd x then return Nothing else return $ Just x)-filterEven n = composeN n $ S.filter even-filterAllOut n = composeN n $ S.filter (> maxValue)-filterAllIn n = composeN n $ S.filter (<= maxValue)-takeOne n = composeN n $ S.take 1-takeAll n = composeN n $ S.take maxValue-takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)-takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))-dropOne n = composeN n $ S.drop 1-dropAll n = composeN n $ S.drop maxValue-dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)-dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))-dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)-foldrS n = composeN n $ S.foldrS S.cons S.nil-foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil-concatMap n = composeN n $ (\s -> S.concatMap (\_ -> s) s)-intersperse n = composeN n $ S.intersperse maxValue------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource- :: Monad m- => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)- where- f (0 :: Int) m = g m- f x m = g (f (x P.- 1) m)--{-# INLINE iterateMapM #-}-{-# INLINE iterateScan #-}-{-# INLINE iterateFilterEven #-}-{-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,- iterateDropWhileFalse, iterateDropWhileTrue- :: Monad m- => Int -> Stream m Int---- this is quadratic-iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)-iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))- (maxIters `div` 10)--iterateMapM = iterateSource (S.mapM return) maxIters-iterateFilterEven = iterateSource (S.filter even) maxIters-iterateTakeAll = iterateSource (S.take maxValue) maxIters-iterateDropOne = iterateSource (S.drop 1) maxIters-iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters--{-# INLINE iterateM #-}-iterateM :: Monad m => Int -> Stream m Int-iterateM i = S.take maxIters (S.iterateM (\x -> return (x + 1)) (return i))------------------------------------------------------------------------------------ Zipping and concat----------------------------------------------------------------------------------{-# INLINE eqBy #-}-eqBy :: (Monad m, P.Eq a) => S.Stream m a -> m P.Bool-eqBy src = S.eqBy (==) src src--{-# INLINE cmpBy #-}-cmpBy :: (Monad m, P.Ord a) => S.Stream m a -> m P.Ordering-cmpBy src = S.cmpBy P.compare src src--{-# INLINE zip #-}-zip :: Monad m => Stream m Int -> m ()-zip src = transform $ S.zipWith (,) src src--{-# INLINE concatMapRepl4xN #-}-concatMapRepl4xN :: Monad m => Stream m Int -> m ()-concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)--{-# INLINE concatMapURepl4xN #-}-concatMapURepl4xN :: Monad m => Stream m Int -> m ()-concatMapURepl4xN src = transform $ S.concatMapU (UF.replicateM 4) src------------------------------------------------------------------------------------ Mixed Composition----------------------------------------------------------------------------------{-# INLINE scanMap #-}-{-# INLINE dropMap #-}-{-# INLINE dropScan #-}-{-# INLINE takeDrop #-}-{-# INLINE takeScan #-}-{-# INLINE takeMap #-}-{-# INLINE filterDrop #-}-{-# INLINE filterTake #-}-{-# INLINE filterScan #-}-{-# INLINE filterMap #-}-scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,- filterTake, filterScan, filterMap- :: Monad m => Int -> Stream m Int -> m ()--scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop n = composeN n $ S.drop 1 . S.take maxValue-takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue-takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue-filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)-filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)------------------------------------------------------------------------------------ Nested Composition----------------------------------------------------------------------------------{-# INLINE toNullApNested #-}-toNullApNested :: Monad m => Stream m Int -> m ()-toNullApNested s = runStream $ do- (+) <$> s <*> s--{-# INLINE toNullNested #-}-toNullNested :: Monad m => Stream m Int -> m ()-toNullNested s = runStream $ do- x <- s- y <- s- return $ x + y--{-# INLINE toNullNested3 #-}-toNullNested3 :: Monad m => Stream m Int -> m ()-toNullNested3 s = runStream $ do- x <- s- y <- s- z <- s- return $ x + y + z--{-# INLINE filterAllOutNested #-}-filterAllOutNested- :: Monad m- => Stream m Int -> m ()-filterAllOutNested str = runStream $ do- x <- str- y <- str- let s = x + y- if s < 0- then return s- else S.nil--{-# INLINE filterAllInNested #-}-filterAllInNested- :: Monad m- => Stream m Int -> m ()-filterAllInNested str = runStream $ do- x <- str- y <- str- let s = x + y- if s > 0- then return s- else S.nil
− benchmark/StreamKOps.hs
@@ -1,410 +0,0 @@--- |--- Module : StreamKOps--- Copyright : (c) 2018 Harendra Kumar------ License : BSD3--- Maintainer : streamly@composewell.com--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module StreamKOps where--import Control.Monad (when)-import Data.Maybe (isJust)-import Prelude- (Monad, Int, (+), ($), (.), return, even, (>), (<=), div,- subtract, undefined, Maybe(..), not, (>>=),- maxBound, flip, (<$>), (<*>), round, (/), (**), (<))-import qualified Prelude as P-import qualified Data.List as List--import qualified Streamly.Internal.Data.Stream.StreamK as S-import qualified Streamly.Internal.Data.Stream.Prelude as SP-import qualified Streamly.Internal.Data.SVar as S--value, value2, value3, value16, maxValue :: Int-value = 100000-value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop-value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop-value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop-maxValue = value------------------------------------------------------------------------------------ Benchmark ops----------------------------------------------------------------------------------{-# INLINE toNull #-}-{-# INLINE uncons #-}-{-# INLINE nullTail #-}-{-# INLINE headTail #-}-{-# INLINE zip #-}-toNull, uncons, nullTail, headTail, zip- :: Monad m- => Stream m Int -> m ()--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]-{-# INLINE foldl #-}-foldl :: Monad m => Stream m Int -> m Int-{-# INLINE last #-}-last :: Monad m => Stream m Int -> m (Maybe Int)------------------------------------------------------------------------------------ Stream generation and elimination----------------------------------------------------------------------------------type Stream m a = S.Stream m a--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: Int -> Stream m Int-sourceUnfoldr n = S.unfoldr step n- where- step cnt =- if cnt > n + value- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrN #-}-sourceUnfoldrN :: Int -> Int -> Stream m Int-sourceUnfoldrN m n = S.unfoldr step n- where- step cnt =- if cnt > n + m- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: S.MonadAsync m => Int -> Stream m Int-sourceUnfoldrM n = S.unfoldrM step n- where- step cnt =- if cnt > n + value- then return Nothing- else return (Just (cnt, cnt + 1))--{-# INLINE sourceUnfoldrMN #-}-sourceUnfoldrMN :: S.MonadAsync m => Int -> Int -> Stream m Int-sourceUnfoldrMN m n = S.unfoldrM step n- where- step cnt =- if cnt > n + m- then return Nothing- else return (Just (cnt, cnt + 1))--{--{-# INLINE sourceFromEnum #-}-sourceFromEnum :: Monad m => Int -> Stream m Int-sourceFromEnum n = S.enumFromStepN n 1 value--}--{-# INLINE sourceFromFoldable #-}-sourceFromFoldable :: Int -> Stream m Int-sourceFromFoldable n = S.fromFoldable [n..n+value]--{--{-# INLINE sourceFromFoldableM #-}-sourceFromFoldableM :: S.MonadAsync m => Int -> Stream m Int-sourceFromFoldableM n = S.fromFoldableM (Prelude.fmap return [n..n+value])--}--{-# INLINE sourceFoldMapWith #-}-sourceFoldMapWith :: Int -> Stream m Int-sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]--{-# INLINE sourceFoldMapWithM #-}-sourceFoldMapWithM :: Monad m => Int -> Stream m Int-sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]--{-# INLINE source #-}-source :: S.MonadAsync m => Int -> Stream m Int-source = sourceUnfoldrM------------------------------------------------------------------------------------ Elimination----------------------------------------------------------------------------------{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--- runStream = S.mapM_ (\_ -> return ())--{-# INLINE mapM_ #-}-mapM_ :: Monad m => Stream m a -> m ()-mapM_ = S.mapM_ (\_ -> return ())--toNull = runStream-uncons s = do- r <- S.uncons s- case r of- Nothing -> return ()- Just (_, t) -> uncons t--{-# INLINE init #-}-init :: (Monad m, S.IsStream t) => t m a -> m ()-init s = do- t <- S.init s- P.mapM_ S.drain t--{-# INLINE tail #-}-tail :: (Monad m, S.IsStream t) => t m a -> m ()-tail s = S.tail s >>= P.mapM_ tail--nullTail s = do- r <- S.null s- when (not r) $ S.tail s >>= P.mapM_ nullTail--headTail s = do- h <- S.head s- when (isJust h) $ S.tail s >>= P.mapM_ headTail--toList = S.toList-foldl = S.foldl' (+) 0-last = S.last------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{-# INLINE transform #-}-transform :: Monad m => Stream m a -> m ()-transform = runStream--{-# INLINE composeN #-}-composeN- :: Monad m- => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()-composeN n f =- case n of- 1 -> transform . f- 2 -> transform . f . f- 3 -> transform . f . f . f- 4 -> transform . f . f . f . f- _ -> undefined--{-# INLINE scan #-}-{-# INLINE map #-}-{-# INLINE fmap #-}-{-# INLINE filterEven #-}-{-# INLINE filterAllOut #-}-{-# INLINE filterAllIn #-}-{-# INLINE takeOne #-}-{-# INLINE takeAll #-}-{-# INLINE takeWhileTrue #-}-{-# INLINE dropOne #-}-{-# INLINE dropAll #-}-{-# INLINE dropWhileTrue #-}-{-# INLINE dropWhileFalse #-}-{-# INLINE foldlS #-}-{-# INLINE concatMap #-}-scan, map, fmap, filterEven, filterAllOut,- filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropOne,- dropWhileTrue, dropWhileFalse, foldlS, concatMap- :: Monad m- => Int -> Stream m Int -> m ()--{-# INLINE mapM #-}-{-# INLINE mapMSerial #-}-{-# INLINE intersperse #-}-mapM, mapMSerial, intersperse- :: S.MonadAsync m => Int -> Stream m Int -> m ()--scan n = composeN n $ S.scanl' (+) 0-map n = composeN n $ P.fmap (+1)-fmap n = composeN n $ P.fmap (+1)-mapM n = composeN n $ S.mapM return-mapMSerial n = composeN n $ S.mapMSerial return-filterEven n = composeN n $ S.filter even-filterAllOut n = composeN n $ S.filter (> maxValue)-filterAllIn n = composeN n $ S.filter (<= maxValue)-takeOne n = composeN n $ S.take 1-takeAll n = composeN n $ S.take maxValue-takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)-dropOne n = composeN n $ S.drop 1-dropAll n = composeN n $ S.drop maxValue-dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)-dropWhileFalse n = composeN n $ S.dropWhile (<= 1)-foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil--- We use a (sqrt n) element stream as source and then concat the same stream--- for each element to produce an n element stream.-concatMap n = composeN n $ (\s -> S.concatMap (\_ -> s) s)-intersperse n = composeN n $ S.intersperse maxValue------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource- :: S.MonadAsync m- => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)- where- f (0 :: Int) m = g m- f x m = g (f (x P.- 1) m)--{-# INLINE iterateMapM #-}-{-# INLINE iterateScan #-}-{-# INLINE iterateFilterEven #-}-{-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,- iterateDropWhileFalse, iterateDropWhileTrue- :: S.MonadAsync m- => Int -> Stream m Int---- this is quadratic-iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)-iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))- (maxIters `div` 10)--iterateMapM = iterateSource (S.mapM return) maxIters-iterateFilterEven = iterateSource (S.filter even) maxIters-iterateTakeAll = iterateSource (S.take maxValue) maxIters-iterateDropOne = iterateSource (S.drop 1) maxIters-iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters------------------------------------------------------------------------------------ Zipping and concat----------------------------------------------------------------------------------zip src = transform $ S.zipWith (,) src src--{-# INLINE concatMapRepl4xN #-}-concatMapRepl4xN :: Monad m => Stream m Int -> m ()-concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)------------------------------------------------------------------------------------ Mixed Composition----------------------------------------------------------------------------------{-# INLINE scanMap #-}-{-# INLINE dropMap #-}-{-# INLINE dropScan #-}-{-# INLINE takeDrop #-}-{-# INLINE takeScan #-}-{-# INLINE takeMap #-}-{-# INLINE filterDrop #-}-{-# INLINE filterTake #-}-{-# INLINE filterScan #-}-{-# INLINE filterMap #-}-scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,- filterTake, filterScan, filterMap- :: Monad m => Int -> Stream m Int -> m ()--scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop n = composeN n $ S.drop 1 . S.take maxValue-takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue-takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue-filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)-filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)------------------------------------------------------------------------------------ Nested Composition----------------------------------------------------------------------------------{-# INLINE toNullApNested #-}-toNullApNested :: Monad m => Stream m Int -> m ()-toNullApNested s = runStream $ do- (+) <$> s <*> s--{-# INLINE toNullNested #-}-toNullNested :: Monad m => Stream m Int -> m ()-toNullNested s = runStream $ do- x <- s- y <- s- return $ x + y--{-# INLINE toNullNested3 #-}-toNullNested3 :: Monad m => Stream m Int -> m ()-toNullNested3 s = runStream $ do- x <- s- y <- s- z <- s- return $ x + y + z--{-# INLINE filterAllOutNested #-}-filterAllOutNested- :: Monad m- => Stream m Int -> m ()-filterAllOutNested str = runStream $ do- x <- str- y <- str- let s = x + y- if s < 0- then return s- else S.nil--{-# INLINE filterAllInNested #-}-filterAllInNested- :: Monad m- => Stream m Int -> m ()-filterAllInNested str = runStream $ do- x <- str- y <- str- let s = x + y- if s > 0- then return s- else S.nil------------------------------------------------------------------------------------ Nested Composition Pure lists----------------------------------------------------------------------------------{-# INLINE sourceUnfoldrList #-}-sourceUnfoldrList :: Int -> Int -> [Int]-sourceUnfoldrList maxval n = List.unfoldr step n- where- step cnt =- if cnt > n + maxval- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE toNullApNestedList #-}-toNullApNestedList :: [Int] -> [Int]-toNullApNestedList s = (+) <$> s <*> s--{-# INLINE toNullNestedList #-}-toNullNestedList :: [Int] -> [Int]-toNullNestedList s = do- x <- s- y <- s- return $ x + y--{-# INLINE toNullNestedList3 #-}-toNullNestedList3 :: [Int] -> [Int]-toNullNestedList3 s = do- x <- s- y <- s- z <- s- return $ x + y + z--{-# INLINE filterAllOutNestedList #-}-filterAllOutNestedList :: [Int] -> [Int]-filterAllOutNestedList str = do- x <- str- y <- str- let s = x + y- if s < 0- then return s- else []--{-# INLINE filterAllInNestedList #-}-filterAllInNestedList :: [Int] -> [Int]-filterAllInNestedList str = do- x <- str- y <- str- let s = x + y- if s > 0- then return s- else []
+ benchmark/Streamly/Benchmark/Data/Fold.hs view
@@ -0,0 +1,230 @@+-- |+-- Module : Streamly.Benchmark.Data.Fold+-- Copyright : (c) 2018 Composewell+--+-- License : MIT+-- Maintainer : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}++module Main (main) where++import Control.DeepSeq (NFData(..))+import Data.Monoid (Last(..))++import System.Random (randomRIO)+import Prelude (IO, Int, Double, String, (>), (<*>), (<$>), (+), ($),+ (<=), Monad(..), (==), Maybe(..), (.), fromIntegral,+ compare, (>=), concat, seq)++import qualified Streamly as S hiding (runStream)+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Pipe as Pipe++import qualified Streamly.Internal.Data.Sink as Sink++import qualified Streamly.Memory.Array as A+import qualified Streamly.Internal.Memory.Array as IA+import qualified Streamly.Internal.Data.Fold as IFL+import qualified Streamly.Internal.Prelude as IP++import Gauge+import Streamly hiding (runStream)+import Streamly.Benchmark.Common++-- We need a monadic bind here to make sure that the function f does not get+-- completely optimized out by the compiler in some cases.++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM value n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE source #-}+source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+source = sourceUnfoldrM++-- | Takes a fold method, and uses it with a default source.+{-# INLINE benchIOSink #-}+benchIOSink+ :: (IsStream t, NFData b)+ => Int -> String -> (t IO Int -> IO b) -> Benchmark+benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . source value++-------------------------------------------------------------------------------+-- Stream folds+-------------------------------------------------------------------------------++o_1_space_serial_folds :: Int -> [Benchmark]+o_1_space_serial_folds value =+ [ bgroup+ "serially"+ [ bgroup+ "folds"+ [ benchIOSink value "drain" (S.fold FL.drain)+ , benchIOSink value "drainN" (S.fold (IFL.drainN value))+ , benchIOSink+ value+ "drainWhileTrue"+ (S.fold (IFL.drainWhile $ (<=) (value + 1)))+ , benchIOSink+ value+ "drainWhileFalse"+ (S.fold (IFL.drainWhile $ (>=) (value + 1)))+ , benchIOSink value "sink" (S.fold $ Sink.toFold Sink.drain)+ , benchIOSink value "last" (S.fold FL.last)+ , benchIOSink value "lastN.1" (S.fold (IA.lastN 1))+ , benchIOSink value "lastN.10" (S.fold (IA.lastN 10))+ , benchIOSink value "length" (S.fold FL.length)+ , benchIOSink value "sum" (S.fold FL.sum)+ , benchIOSink value "product" (S.fold FL.product)+ , benchIOSink value "maximumBy" (S.fold (FL.maximumBy compare))+ , benchIOSink value "maximum" (S.fold FL.maximum)+ , benchIOSink value "minimumBy" (S.fold (FL.minimumBy compare))+ , benchIOSink value "minimum" (S.fold FL.minimum)+ , benchIOSink+ value+ "mean"+ (\s ->+ S.fold+ FL.mean+ (S.map (fromIntegral :: Int -> Double) s))+ , benchIOSink+ value+ "variance"+ (\s ->+ S.fold+ FL.variance+ (S.map (fromIntegral :: Int -> Double) s))+ , benchIOSink+ value+ "stdDev"+ (\s ->+ S.fold+ FL.stdDev+ (S.map (fromIntegral :: Int -> Double) s))+ , benchIOSink+ value+ "mconcat"+ (S.fold FL.mconcat . (S.map (Last . Just)))+ , benchIOSink+ value+ "foldMap"+ (S.fold (FL.foldMap (Last . Just)))+ , benchIOSink value "index" (S.fold (FL.index (value + 1)))+ , benchIOSink value "head" (S.fold FL.head)+ , benchIOSink value "find" (S.fold (FL.find (== (value + 1))))+ , benchIOSink+ value+ "findIndex"+ (S.fold (FL.findIndex (== (value + 1))))+ , benchIOSink+ value+ "elemIndex"+ (S.fold (FL.elemIndex (value + 1)))+ , benchIOSink value "null" (S.fold FL.null)+ , benchIOSink value "elem" (S.fold (FL.elem (value + 1)))+ , benchIOSink value "notElem" (S.fold (FL.notElem (value + 1)))+ , benchIOSink value "all" (S.fold (FL.all (<= (value + 1))))+ , benchIOSink value "any" (S.fold (FL.any (> (value + 1))))+ , benchIOSink+ value+ "and"+ (\s -> S.fold FL.and (S.map (<= (value + 1)) s))+ , benchIOSink+ value+ "or"+ (\s -> S.fold FL.or (S.map (> (value + 1)) s))+ ]+ ]+ ]+++o_1_space_serial_foldsTransforms :: Int -> [Benchmark]+o_1_space_serial_foldsTransforms value =+ [ bgroup+ "serially"+ [ bgroup+ "folds-transforms"+ [ benchIOSink value "drain" (S.fold FL.drain)+ , benchIOSink value "lmap" (S.fold (IFL.lmap (+ 1) FL.drain))+ , benchIOSink+ value+ "pipe-mapM"+ (S.fold+ (IFL.transform+ (Pipe.mapM (\x -> return $ x + 1))+ FL.drain))+ ]+ ]+ ]+++o_1_space_serial_foldsCompositions :: Int -> [Benchmark]+o_1_space_serial_foldsCompositions value =+ [ bgroup+ "serially"+ [ bgroup+ "folds-compositions" -- Applicative+ [ benchIOSink+ value+ "all,any"+ (S.fold+ ((,) <$> FL.all (<= (value + 1)) <*>+ FL.any (> (value + 1))))+ , benchIOSink+ value+ "sum,length"+ (S.fold ((,) <$> FL.sum <*> FL.length))+ ]+ ]+ ]+++o_n_heap_serial_folds :: Int -> [Benchmark]+o_n_heap_serial_folds value =+ [ bgroup+ "serially"+ [ bgroup+ "foldl"+ -- Left folds for building a structure are inherently non-streaming+ -- as the structure cannot be lazily consumed until fully built.+ [ benchIOSink value "toStream" (S.fold IP.toStream)+ , benchIOSink value "toStreamRev" (S.fold IP.toStreamRev)+ , benchIOSink value "toList" (S.fold FL.toList)+ , benchIOSink value "toListRevF" (S.fold IFL.toListRevF)+ -- Converting the stream to an array+ , benchIOSink value "lastN.Max" (S.fold (IA.lastN (value + 1)))+ , benchIOSink value "writeN" (S.fold (A.writeN value))+ ]+ ]+ ]++-------------------------------------------------------------------------------+-- Driver+-------------------------------------------------------------------------------++main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)+ where+ allBenchmarks value =+ [ bgroup+ "o-1-space"+ [ bgroup "fold" $+ concat+ [ o_1_space_serial_folds value+ , o_1_space_serial_foldsTransforms value+ , o_1_space_serial_foldsCompositions value+ ]+ ]+ , bgroup+ "o-n-heap"+ [bgroup "fold" $ concat [o_n_heap_serial_folds value]]+ ]
+ benchmark/Streamly/Benchmark/Data/NestedUnfoldOps.hs view
@@ -0,0 +1,126 @@+-- |+-- Module : NestedUnfoldOps+-- Copyright : (c) 2019 Composewell Technologies+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++module Streamly.Benchmark.Data.NestedUnfoldOps where++import Control.Monad.IO.Class (MonadIO (..))+import Streamly.Internal.Data.Unfold (Unfold)++import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.Data.Fold as FL++-- n * (n + 1) / 2 == linearCount+concatCount :: Int -> Int+concatCount linearCount =+ round (((1 + 8 * fromIntegral linearCount)**(1/2::Double) - 1) / 2)++-- double nested loop+nestedCount2 :: Int -> Int+nestedCount2 linearCount = round (fromIntegral linearCount**(1/2::Double))++-- triple nested loop+nestedCount3 :: Int -> Int+nestedCount3 linearCount = round (fromIntegral linearCount**(1/3::Double))++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++-- generate numbers up to the argument value+{-# INLINE source #-}+source :: Monad m => Int -> Unfold m Int Int+source n = UF.enumerateFromToIntegral n++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++{-# INLINE toNull #-}+toNull :: MonadIO m => Int -> Int -> m ()+toNull linearCount start = do+ let end = start + nestedCount2 linearCount+ UF.fold+ (UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end))+ FL.drain (start, start)++{-# INLINE toNull3 #-}+toNull3 :: MonadIO m => Int -> Int -> m ()+toNull3 linearCount start = do+ let end = start + nestedCount3 linearCount+ UF.fold+ (UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end)+ ((UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end))))+ FL.drain (start, (start, start))++{-# INLINE concat #-}+concat :: MonadIO m => Int -> Int -> m ()+concat linearCount start = do+ let end = start + concatCount linearCount+ UF.fold+ (UF.concat (source end) (source end))+ FL.drain start++{-# INLINE toList #-}+toList :: MonadIO m => Int -> Int -> m [Int]+toList linearCount start = do+ let end = start + nestedCount2 linearCount+ UF.fold+ (UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end))+ FL.toList (start, start)++{-# INLINE toListSome #-}+toListSome :: MonadIO m => Int -> Int -> m [Int]+toListSome linearCount start = do+ let end = start + nestedCount2 linearCount+ UF.fold+ (UF.take 1000 $ (UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end)))+ FL.toList (start, start)++{-# INLINE filterAllOut #-}+filterAllOut :: MonadIO m => Int -> Int -> m ()+filterAllOut linearCount start = do+ let end = start + nestedCount2 linearCount+ UF.fold+ (UF.filter (< 0)+ $ UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end))+ FL.drain (start, start)++{-# INLINE filterAllIn #-}+filterAllIn :: MonadIO m => Int -> Int -> m ()+filterAllIn linearCount start = do+ let end = start + nestedCount2 linearCount+ UF.fold+ (UF.filter (> 0)+ $ UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end))+ FL.drain (start, start)++{-# INLINE filterSome #-}+filterSome :: MonadIO m => Int -> Int -> m ()+filterSome linearCount start = do+ let end = start + nestedCount2 linearCount+ UF.fold+ (UF.filter (> 1100000)+ $ UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end))+ FL.drain (start, start)++{-# INLINE breakAfterSome #-}+breakAfterSome :: MonadIO m => Int -> Int -> m ()+breakAfterSome linearCount start = do+ let end = start + nestedCount2 linearCount+ UF.fold+ (UF.takeWhile (<= 1100000)+ $ UF.map (\(x, y) -> x + y)+ $ UF.outerProduct (source end) (source end))+ FL.drain (start, start)
+ benchmark/Streamly/Benchmark/Data/Parser.hs view
@@ -0,0 +1,215 @@+-- |+-- Module : Streamly.Benchmark.Data.Parser+-- Copyright : (c) 2020 Composewell Technologies+--+-- License : MIT+-- Maintainer : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fspec-constr-recursive=4 #-}++module Main+ (+ main+ ) where++import Control.DeepSeq (NFData(..))+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Data.Foldable (asum)+import System.Random (randomRIO)+import Prelude hiding (any, all, take, sequence, sequenceA, takeWhile)++import qualified Data.Traversable as TR+import qualified Control.Applicative as AP+import qualified Streamly as S hiding (runStream)+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Prelude as IP++import Gauge+import Streamly hiding (runStream)+import Streamly.Benchmark.Common++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++-- XXX these can be moved to the common module++-- We need a monadic bind here to make sure that the function f does not get+-- completely optimized out by the compiler in some cases.++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM value n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (cnt, cnt + 1))++-- | Takes a fold method, and uses it with a default source.+{-# INLINE benchIOSink #-}+benchIOSink+ :: (IsStream t, NFData b)+ => Int -> String -> (t IO Int -> IO b) -> Benchmark+benchIOSink value name f =+ bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value++-------------------------------------------------------------------------------+-- Parsers+-------------------------------------------------------------------------------++{-# INLINE any #-}+any :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool+any value = IP.parse (PR.any (> value))++{-# INLINE all #-}+all :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool+all value = IP.parse (PR.all (<= value))++{-# INLINE take #-}+take :: MonadThrow m => Int -> SerialT m a -> m ()+take value = IP.parse (PR.take value FL.drain)++{-# INLINE takeWhile #-}+takeWhile :: MonadThrow m => Int -> SerialT m Int -> m ()+takeWhile value = IP.parse (PR.takeWhile (<= value) FL.drain)++{-# INLINE many #-}+many :: MonadCatch m => SerialT m Int -> m Int+many = IP.parse (PR.many FL.length (PR.satisfy (> 0)))++{-# INLINE manyAlt #-}+manyAlt :: MonadCatch m => SerialT m Int -> m Int+manyAlt xs = do+ x <- IP.parse (AP.many (PR.satisfy (> 0))) xs+ return $ Prelude.length x++{-# INLINE some #-}+some :: MonadCatch m => SerialT m Int -> m Int+some = IP.parse (PR.some FL.length (PR.satisfy (> 0)))++{-# INLINE someAlt #-}+someAlt :: MonadCatch m => SerialT m Int -> m Int+someAlt xs = do+ x <- IP.parse (AP.some (PR.satisfy (> 0))) xs+ return $ Prelude.length x++{-# INLINE manyTill #-}+manyTill :: MonadCatch m => Int -> SerialT m Int -> m Int+manyTill value =+ IP.parse (PR.manyTill FL.length (PR.satisfy (> 0)) (PR.satisfy (== value)))++{-# INLINE splitAllAny #-}+splitAllAny :: MonadThrow m+ => Int -> SerialT m Int -> m (Bool, Bool)+splitAllAny value =+ IP.parse ((,) <$> PR.all (<= (value `div` 2)) <*> PR.any (> value))++{-# INLINE teeAllAny #-}+teeAllAny :: (MonadThrow m, Ord a)+ => a -> SerialT m a -> m (Bool, Bool)+teeAllAny value =+ IP.parse (PR.teeWith (,) (PR.all (<= value)) (PR.any (> value)))++{-# INLINE teeFstAllAny #-}+teeFstAllAny :: (MonadThrow m, Ord a)+ => a -> SerialT m a -> m (Bool, Bool)+teeFstAllAny value =+ IP.parse (PR.teeWithFst (,) (PR.all (<= value)) (PR.any (> value)))++{-# INLINE shortestAllAny #-}+shortestAllAny :: (MonadThrow m, Ord a)+ => a -> SerialT m a -> m Bool+shortestAllAny value =+ IP.parse (PR.shortest (PR.all (<= value)) (PR.any (> value)))++{-# INLINE longestAllAny #-}+longestAllAny :: (MonadCatch m, Ord a)+ => a -> SerialT m a -> m Bool+longestAllAny value =+ IP.parse (PR.longest (PR.all (<= value)) (PR.any (> value)))++-------------------------------------------------------------------------------+-- Parsers in which -fspec-constr-recursive=16 is problematic+-------------------------------------------------------------------------------++-- XXX -fspec-constr-recursive=16 makes GHC go beserk when compiling these.+-- We need to fix GHC so that we can have better control over that option or do+-- not have to rely on it.+--+{-# INLINE lookAhead #-}+lookAhead :: MonadThrow m => Int -> SerialT m Int -> m ()+lookAhead value =+ IP.parse (PR.lookAhead (PR.takeWhile (<= value) FL.drain) *> pure ())++-- quadratic complexity+{-# INLINE sequenceA #-}+sequenceA :: MonadThrow m => Int -> SerialT m Int -> m Int+sequenceA value xs = do+ x <- IP.parse (TR.sequenceA (replicate value (PR.satisfy (> 0)))) xs+ return $ length x++-- quadratic complexity+{-# INLINE sequence #-}+sequence :: MonadThrow m => Int -> SerialT m Int -> m Int+sequence value xs = do+ x <- IP.parse (TR.sequence (replicate value (PR.satisfy (> 0)))) xs+ return $ length x++-- choice using the "Alternative" instance with direct style parser type has+-- quadratic performance complexity.+--+{-# INLINE choice #-}+choice :: MonadCatch m => Int -> SerialT m Int -> m Int+choice value = do+ IP.parse (asum (replicate value (PR.satisfy (< 0)))+ AP.<|> PR.satisfy (> 0))++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++o_1_space_serial_parse :: Int -> [Benchmark]+o_1_space_serial_parse value =+ [ benchIOSink value "any" $ any value+ , benchIOSink value "all" $ all value+ , benchIOSink value "take" $ take value+ , benchIOSink value "takeWhile" $ takeWhile value+ , benchIOSink value "lookAhead" $ lookAhead value+ , benchIOSink value "split (all,any)" $ splitAllAny value+ , benchIOSink value "many" many+ , benchIOSink value "some" some+ , benchIOSink value "manyAlt" manyAlt+ , benchIOSink value "someAlt" someAlt+ , benchIOSink value "manyTill" $ manyTill value+ , benchIOSink value "choice/100" $ choice (value `div` 100)+ , benchIOSink value "tee (all,any)" $ teeAllAny value+ , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value+ , benchIOSink value "shortest (all,any)" $ shortestAllAny value+ , benchIOSink value "longest (all,any)" $ longestAllAny value+ , benchIOSink value "sequenceA/100" $ sequenceA (value `div` 100)+ , benchIOSink value "sequence/100" $ sequence (value `div` 100)+ ]++-------------------------------------------------------------------------------+-- Driver+-------------------------------------------------------------------------------++main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)++ where++ allBenchmarks value =+ [ bgroup "o1"+ [ bgroup "parser" $ concat+ [+ o_1_space_serial_parse value+ ]+ ]+ ]
+ benchmark/Streamly/Benchmark/Data/Stream/BaseStreams.hs view
@@ -0,0 +1,40 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++{-# LANGUAGE CPP #-}++import qualified Streamly.Benchmark.Data.Stream.StreamK as K++#if !defined(O_N_HEAP)+import qualified Streamly.Benchmark.Data.Stream.StreamD as D+#endif++#ifdef O_1_SPACE+import qualified Streamly.Benchmark.Data.Stream.StreamDK as DK+#endif++import Gauge++main :: IO ()+main =+ defaultMain $+#ifdef O_1_SPACE+ D.o_1_space+ ++ K.o_1_space_list+ ++ K.o_1_space+ ++ DK.o_1_space+#elif defined(O_N_HEAP)+ K.o_n_heap+#elif defined(O_N_STACK)+ D.o_n_stack+ ++ K.o_n_stack+#elif defined(O_N_SPACE)+ D.o_n_space+ ++ K.o_n_space+#else+#error "One of O_1_SPACE/O_N_HEAP/O_N_STACK/O_N_SPACE must be defined"+#endif
+ benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs view
@@ -0,0 +1,541 @@+-- |+-- Module : Streamly.Benchmark.Data.Stream.StreamD+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Streamly.Benchmark.Data.Stream.StreamD+ (+ o_1_space+ , o_n_stack+ , o_n_space+ )+where++import Control.Monad (when)+import Data.Maybe (isJust)+import Prelude+ (Monad, Int, (+), ($), (.), return, (>), even, (<=), div,+ subtract, undefined, Maybe(..), not, (>>=),+ maxBound, fmap, odd, (==), flip, (<$>), (<*>), round, (/), (**), (<))+import System.Random (randomRIO)++import qualified Prelude as P++import qualified Streamly.Internal.Data.Stream.StreamD as S+import qualified Streamly.Internal.Data.Unfold as UF++import Streamly.Benchmark.Common (benchFold)+import Gauge (bench, nfIO, bgroup, Benchmark)+++-- We try to keep the total number of iterations same irrespective of nesting+-- of the loops so that the overhead is easy to compare.+value, value2, value3, value16, maxValue :: Int+value = 100000+value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop+value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop+value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop+maxValue = value++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++type Stream m a = S.Stream m a++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: Monad m => Int -> Stream m Int+sourceUnfoldr n = S.unfoldr step n+ where+ step cnt =+ if cnt > n + value+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrN #-}+sourceUnfoldrN :: Monad m => Int -> Int -> Stream m Int+sourceUnfoldrN m n = S.unfoldr step n+ where+ step cnt =+ if cnt > n + m+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrMN #-}+sourceUnfoldrMN :: Monad m => Int -> Int -> Stream m Int+sourceUnfoldrMN m n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + m+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: Monad m => Int -> Stream m Int+sourceUnfoldrM n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE sourceIntFromTo #-}+sourceIntFromTo :: Monad m => Int -> Stream m Int+sourceIntFromTo n = S.enumerateFromToIntegral n (n + value)++{-# INLINE sourceFromList #-}+sourceFromList :: Monad m => Int -> Stream m Int+sourceFromList n = S.fromList [n..n+value]++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.drain++{-# INLINE mapM_ #-}+mapM_ :: Monad m => Stream m a -> m ()+mapM_ = S.mapM_ (\_ -> return ())++{-# INLINE toNull #-}+toNull :: Monad m => Stream m Int -> m ()+toNull = runStream++{-# INLINE uncons #-}+{-# INLINE nullTail #-}+{-# INLINE headTail #-}+uncons, nullTail, headTail+ :: Monad m+ => Stream m Int -> m ()++uncons s = do+ r <- S.uncons s+ case r of+ Nothing -> return ()+ Just (_, t) -> uncons t++{-# INLINE tail #-}+tail :: Monad m => Stream m a -> m ()+tail s = S.tail s >>= P.mapM_ tail++nullTail s = do+ r <- S.null s+ when (not r) $ S.tail s >>= P.mapM_ nullTail++headTail s = do+ h <- S.head s+ when (isJust h) $ S.tail s >>= P.mapM_ headTail++{-# INLINE toList #-}+toList :: Monad m => Stream m Int -> m [Int]+toList = S.toList++{-# INLINE foldl #-}+foldl :: Monad m => Stream m Int -> m Int+foldl = S.foldl' (+) 0++{-# INLINE last #-}+last :: Monad m => Stream m Int -> m (Maybe Int)+last = S.last++-------------------------------------------------------------------------------+-- Transformation+-------------------------------------------------------------------------------++{-# INLINE transform #-}+transform :: Monad m => Stream m a -> m ()+transform = runStream++{-# INLINE composeN #-}+composeN+ :: Monad m+ => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()+composeN n f =+ case n of+ 1 -> transform . f+ 2 -> transform . f . f+ 3 -> transform . f . f . f+ 4 -> transform . f . f . f . f+ _ -> undefined++{-# INLINE scan #-}+{-# INLINE map #-}+{-# INLINE fmapD #-}+{-# INLINE mapM #-}+{-# INLINE mapMaybe #-}+{-# INLINE mapMaybeM #-}+{-# INLINE filterEven #-}+{-# INLINE filterAllOut #-}+{-# INLINE filterAllIn #-}+{-# INLINE _takeOne #-}+{-# INLINE takeAll #-}+{-# INLINE takeWhileTrue #-}+{-# INLINE _takeWhileMTrue #-}+{-# INLINE dropOne #-}+{-# INLINE dropAll #-}+{-# INLINE dropWhileTrue #-}+{-# INLINE _dropWhileMTrue #-}+{-# INLINE dropWhileFalse #-}+{-# INLINE _foldrS #-}+{-# INLINE _foldlS #-}+{-# INLINE concatMap #-}+{-# INLINE intersperse #-}+scan, map, fmapD, mapM, mapMaybe, mapMaybeM, filterEven, filterAllOut,+ filterAllIn, _takeOne, takeAll, takeWhileTrue, _takeWhileMTrue, dropOne,+ dropAll, dropWhileTrue, _dropWhileMTrue, dropWhileFalse, _foldrS, _foldlS,+ concatMap, intersperse+ :: Monad m+ => Int -> Stream m Int -> m ()++scan n = composeN n $ S.scanl' (+) 0+fmapD n = composeN n $ Prelude.fmap (+1)+map n = composeN n $ S.map (+1)+mapM n = composeN n $ S.mapM return+mapMaybe n = composeN n $ S.mapMaybe+ (\x -> if Prelude.odd x then Nothing else Just x)+mapMaybeM n = composeN n $ S.mapMaybeM+ (\x -> if Prelude.odd x then return Nothing else return $ Just x)+filterEven n = composeN n $ S.filter even+filterAllOut n = composeN n $ S.filter (> maxValue)+filterAllIn n = composeN n $ S.filter (<= maxValue)+_takeOne n = composeN n $ S.take 1+takeAll n = composeN n $ S.take maxValue+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)+_takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))+dropOne n = composeN n $ S.drop 1+dropAll n = composeN n $ S.drop maxValue+dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)+_dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))+dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)+_foldrS n = composeN n $ S.foldrS S.cons S.nil+_foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil+concatMap n = composeN n $ (\s -> S.concatMap (\_ -> s) s)+intersperse n = composeN n $ S.intersperse maxValue++-------------------------------------------------------------------------------+-- Iteration+-------------------------------------------------------------------------------++iterStreamLen, maxIters :: Int+iterStreamLen = 10+maxIters = 10000++{-# INLINE iterateSource #-}+iterateSource+ :: Monad m+ => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)+ where+ f (0 :: Int) m = g m+ f x m = g (f (x P.- 1) m)++{-# INLINE iterateMapM #-}+{-# INLINE iterateScan #-}+{-# INLINE iterateFilterEven #-}+{-# INLINE iterateTakeAll #-}+{-# INLINE iterateDropOne #-}+{-# INLINE iterateDropWhileFalse #-}+{-# INLINE iterateDropWhileTrue #-}+iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,+ iterateDropWhileFalse, iterateDropWhileTrue+ :: Monad m+ => Int -> Stream m Int++-- this is quadratic+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)+iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))+ (maxIters `div` 10)++iterateMapM = iterateSource (S.mapM return) maxIters+iterateFilterEven = iterateSource (S.filter even) maxIters+iterateTakeAll = iterateSource (S.take maxValue) maxIters+iterateDropOne = iterateSource (S.drop 1) maxIters+iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters++{-# INLINE iterateM #-}+iterateM :: Monad m => Int -> Stream m Int+iterateM i = S.take maxIters (S.iterateM (\x -> return (x + 1)) (return i))++-------------------------------------------------------------------------------+-- Zipping and concat+-------------------------------------------------------------------------------++{-# INLINE eqBy #-}+eqBy :: (Monad m, P.Eq a) => S.Stream m a -> m P.Bool+eqBy src = S.eqBy (==) src src++{-# INLINE cmpBy #-}+cmpBy :: (Monad m, P.Ord a) => S.Stream m a -> m P.Ordering+cmpBy src = S.cmpBy P.compare src src++{-# INLINE zip #-}+zip :: Monad m => Stream m Int -> m ()+zip src = transform $ S.zipWith (,) src src++{-# INLINE concatMapRepl4xN #-}+concatMapRepl4xN :: Monad m => Stream m Int -> m ()+concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)++{-# INLINE concatMapURepl4xN #-}+concatMapURepl4xN :: Monad m => Stream m Int -> m ()+concatMapURepl4xN src = transform $ S.concatMapU (UF.replicateM 4) src++-------------------------------------------------------------------------------+-- Mixed Composition+-------------------------------------------------------------------------------++{-# INLINE scanMap #-}+{-# INLINE dropMap #-}+{-# INLINE dropScan #-}+{-# INLINE takeDrop #-}+{-# INLINE takeScan #-}+{-# INLINE takeMap #-}+{-# INLINE filterDrop #-}+{-# INLINE filterTake #-}+{-# INLINE filterScan #-}+{-# INLINE filterMap #-}+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,+ filterTake, filterScan, filterMap+ :: Monad m => Int -> Stream m Int -> m ()++scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1+takeDrop n = composeN n $ S.drop 1 . S.take maxValue+takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue+takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)+filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++-------------------------------------------------------------------------------+-- Nested Composition+-------------------------------------------------------------------------------++{-# INLINE toNullApNested #-}+toNullApNested :: Monad m => Stream m Int -> m ()+toNullApNested s = runStream $ do+ (+) <$> s <*> s++{-# INLINE toNullNested #-}+toNullNested :: Monad m => Stream m Int -> m ()+toNullNested s = runStream $ do+ x <- s+ y <- s+ return $ x + y++{-# INLINE toNullNested3 #-}+toNullNested3 :: Monad m => Stream m Int -> m ()+toNullNested3 s = runStream $ do+ x <- s+ y <- s+ z <- s+ return $ x + y + z++{-# INLINE filterAllOutNested #-}+filterAllOutNested+ :: Monad m+ => Stream m Int -> m ()+filterAllOutNested str = runStream $ do+ x <- str+ y <- str+ let s = x + y+ if s < 0+ then return s+ else S.nil++{-# INLINE filterAllInNested #-}+filterAllInNested+ :: Monad m+ => Stream m Int -> m ()+filterAllInNested str = runStream $ do+ x <- str+ y <- str+ let s = x + y+ if s > 0+ then return s+ else S.nil++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++o_1_space :: [Benchmark]+o_1_space =+ [ bgroup "streamD"+ [ bgroup "generation"+ [ benchFold "unfoldr" toNull sourceUnfoldr+ , benchFold "unfoldrM" toNull sourceUnfoldrM+ , benchFold "intFromTo" toNull sourceIntFromTo++ , benchFold "fromList" toNull sourceFromList+ ]+ , bgroup "elimination"+ [ benchFold "toNull" toNull sourceUnfoldrM+ , benchFold "mapM_" mapM_ sourceUnfoldrM+ , benchFold "uncons" uncons sourceUnfoldrM+ , benchFold "foldl'" foldl sourceUnfoldrM+ , benchFold "last" last sourceUnfoldrM+ ]+ , bgroup "nested"+ [ benchFold "toNullAp" toNullApNested (sourceUnfoldrMN value2)+ , benchFold "toNull" toNullNested (sourceUnfoldrMN value2)+ , benchFold "toNull3" toNullNested3 (sourceUnfoldrMN value3)+ , benchFold "filterAllIn" filterAllInNested (sourceUnfoldrMN value2)+ , benchFold "filterAllOut" filterAllOutNested (sourceUnfoldrMN value2)+ , benchFold "toNullApPure" toNullApNested (sourceUnfoldrN value2)+ , benchFold "toNullPure" toNullNested (sourceUnfoldrN value2)+ , benchFold "toNull3Pure" toNullNested3 (sourceUnfoldrN value3)+ , benchFold "filterAllInPure" filterAllInNested (sourceUnfoldrN value2)+ , benchFold "filterAllOutPure" filterAllOutNested (sourceUnfoldrN value2)+ ]+ , bgroup "transformation"+ [ benchFold "scan" (scan 1) sourceUnfoldrM+ , benchFold "map" (map 1) sourceUnfoldrM+ , benchFold "fmap" (fmapD 1) sourceUnfoldrM+ , benchFold "mapM" (mapM 1) sourceUnfoldrM+ , benchFold "mapMaybe" (mapMaybe 1) sourceUnfoldrM+ , benchFold "mapMaybeM" (mapMaybeM 1) sourceUnfoldrM+ , benchFold "concatMapNxN" (concatMap 1) (sourceUnfoldrMN value2)+ , benchFold "concatMapRepl4xN" concatMapRepl4xN+ (sourceUnfoldrMN (value `div` 4))+ , benchFold "concatMapPureNxN" (concatMap 1) (sourceUnfoldrN value2)+ , benchFold "concatMapURepl4xN" concatMapURepl4xN+ (sourceUnfoldrMN (value `div` 4))+ ]+ , bgroup "transformationX4"+ [ benchFold "scan" (scan 4) sourceUnfoldrM+ , benchFold "map" (map 4) sourceUnfoldrM+ , benchFold "fmap" (fmapD 4) sourceUnfoldrM+ , benchFold "mapM" (mapM 4) sourceUnfoldrM+ , benchFold "mapMaybe" (mapMaybe 4) sourceUnfoldrM+ , benchFold "mapMaybeM" (mapMaybeM 4) sourceUnfoldrM+ -- XXX this is horribly slow+ -- , benchFold "concatMap" (concatMap 4) (sourceUnfoldrMN value16)+ ]+ , bgroup "filtering"+ [ benchFold "filter-even" (filterEven 1) sourceUnfoldrM+ , benchFold "filter-all-out" (filterAllOut 1) sourceUnfoldrM+ , benchFold "filter-all-in" (filterAllIn 1) sourceUnfoldrM+ , benchFold "take-all" (takeAll 1) sourceUnfoldrM+ , benchFold "takeWhile-true" (takeWhileTrue 1) sourceUnfoldrM+ , benchFold "drop-one" (dropOne 1) sourceUnfoldrM+ , benchFold "drop-all" (dropAll 1) sourceUnfoldrM+ , benchFold "dropWhile-true" (dropWhileTrue 1) sourceUnfoldrM+ , benchFold "dropWhile-false" (dropWhileFalse 1) sourceUnfoldrM+ ]+ , bgroup "filteringX4"+ [ benchFold "filter-even" (filterEven 4) sourceUnfoldrM+ , benchFold "filter-all-out" (filterAllOut 4) sourceUnfoldrM+ , benchFold "filter-all-in" (filterAllIn 4) sourceUnfoldrM+ , benchFold "take-all" (takeAll 4) sourceUnfoldrM+ , benchFold "takeWhile-true" (takeWhileTrue 4) sourceUnfoldrM+ , benchFold "drop-one" (dropOne 4) sourceUnfoldrM+ , benchFold "drop-all" (dropAll 4) sourceUnfoldrM+ , benchFold "dropWhile-true" (dropWhileTrue 4) sourceUnfoldrM+ , benchFold "dropWhile-false" (dropWhileFalse 4) sourceUnfoldrM+ ]+ , bgroup "zipping"+ [ benchFold "eqBy" eqBy sourceUnfoldrM+ , benchFold "cmpBy" cmpBy sourceUnfoldrM+ , benchFold "zip" zip sourceUnfoldrM+ ]+ , bgroup "mixed"+ [ benchFold "scan-map" (scanMap 1) sourceUnfoldrM+ , benchFold "drop-map" (dropMap 1) sourceUnfoldrM+ , benchFold "drop-scan" (dropScan 1) sourceUnfoldrM+ , benchFold "take-drop" (takeDrop 1) sourceUnfoldrM+ , benchFold "take-scan" (takeScan 1) sourceUnfoldrM+ , benchFold "take-map" (takeMap 1) sourceUnfoldrM+ , benchFold "filter-drop" (filterDrop 1) sourceUnfoldrM+ , benchFold "filter-take" (filterTake 1) sourceUnfoldrM+ , benchFold "filter-scan" (filterScan 1) sourceUnfoldrM+ , benchFold "filter-map" (filterMap 1) sourceUnfoldrM+ ]+ , bgroup "mixedX2"+ [ benchFold "scan-map" (scanMap 2) sourceUnfoldrM+ , benchFold "drop-map" (dropMap 2) sourceUnfoldrM+ , benchFold "drop-scan" (dropScan 2) sourceUnfoldrM+ , benchFold "take-drop" (takeDrop 2) sourceUnfoldrM+ , benchFold "take-scan" (takeScan 2) sourceUnfoldrM+ , benchFold "take-map" (takeMap 2) sourceUnfoldrM+ , benchFold "filter-drop" (filterDrop 2) sourceUnfoldrM+ , benchFold "filter-take" (filterTake 2) sourceUnfoldrM+ , benchFold "filter-scan" (filterScan 2) sourceUnfoldrM+ , benchFold "filter-map" (filterMap 2) sourceUnfoldrM+ ]+ , bgroup "mixedX4"+ [ benchFold "scan-map" (scanMap 4) sourceUnfoldrM+ , benchFold "drop-map" (dropMap 4) sourceUnfoldrM+ , benchFold "drop-scan" (dropScan 4) sourceUnfoldrM+ , benchFold "take-drop" (takeDrop 4) sourceUnfoldrM+ , benchFold "take-scan" (takeScan 4) sourceUnfoldrM+ , benchFold "take-map" (takeMap 4) sourceUnfoldrM+ , benchFold "filter-drop" (filterDrop 4) sourceUnfoldrM+ , benchFold "filter-take" (filterTake 4) sourceUnfoldrM+ , benchFold "filter-scan" (filterScan 4) sourceUnfoldrM+ , benchFold "filter-map" (filterMap 4) sourceUnfoldrM+ ]+ ]+ ]++-- | Takes a source, and uses it with a default drain/fold method.+{-# INLINE benchD #-}+benchD :: P.String -> (Int -> Stream P.IO Int) -> Benchmark+benchD name f = bench name $ nfIO $ randomRIO (1,1) >>= toNull . f++o_n_stack :: [Benchmark]+o_n_stack =+ [ bgroup "streamD"+ [ bgroup "elimination"+ [ benchFold "tail" tail sourceUnfoldrM+ , benchFold "nullTail" nullTail sourceUnfoldrM+ , benchFold "headTail" headTail sourceUnfoldrM+ ]+ , bgroup "transformation"+ [+ -- this is horribly slow+ -- benchFold "foldrS" (_foldrS 1) sourceUnfoldrM+ -- XXX why do these need so much stack+ benchFold "intersperse" (intersperse 1) (sourceUnfoldrMN value2)+ , benchFold "interspersePure" (intersperse 1) (sourceUnfoldrN value2)+ ]+ , bgroup "transformationX4"+ [+ benchFold "intersperse" (intersperse 4) (sourceUnfoldrMN value16)+ ]+ , bgroup "iterated"+ [ benchD "mapM" iterateMapM+ , benchD "scan(1/10)" iterateScan+ , benchD "filterEven" iterateFilterEven+ , benchD "takeAll" iterateTakeAll+ , benchD "dropOne" iterateDropOne+ , benchD "dropWhileFalse(1/10)" iterateDropWhileFalse+ , benchD "dropWhileTrue" iterateDropWhileTrue+ , benchD "iterateM" iterateM+ ]+ ]+ ]++o_n_space :: [Benchmark]+o_n_space =+ [ bgroup "streamD"+ [ bgroup "elimination"+ [ benchFold "toList" toList sourceUnfoldrM+ ]+ , bgroup "transformation"+ [++ -- This is horribly slow, never finishes+ -- benchFold "foldlS" (_foldlS 1) sourceUnfoldrM+ ]+ ]+ ]
+ benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs view
@@ -0,0 +1,452 @@+-- |+-- Module : Streamly.Benchmark.Data.Stream.StreamDK+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Streamly.Benchmark.Data.Stream.StreamDK+ (+ o_1_space+ )+where++-- import Control.Monad (when)+-- import Data.Maybe (isJust)+import Prelude+ (Monad, Int, (+), return, Maybe(..), (>))+-- import qualified Prelude as P+-- import qualified Data.List as List++import qualified Streamly.Internal.Data.Stream.StreamDK as S+-- import qualified Streamly.Internal.Data.Stream.Prelude as SP+-- import qualified Streamly.Internal.Data.SVar as S++import Streamly.Benchmark.Common (benchFold)+import Gauge (bgroup, Benchmark)++value :: Int+value = 100000+{-+value2, value3, value16, maxValue :: Int+value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop+value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop+value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop+maxValue = value+-}++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++type Stream m a = S.Stream m a++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: Monad m => Int -> Stream m Int+sourceUnfoldr n = S.unfoldr step n+ where+ step cnt =+ if cnt > n + value+ then Nothing+ else Just (cnt, cnt + 1)++{-+{-# INLINE sourceUnfoldrN #-}+sourceUnfoldrN :: Monad m => Int -> Int -> Stream m Int+sourceUnfoldrN m n = S.unfoldr step n+ where+ step cnt =+ if cnt > n + m+ then Nothing+ else Just (cnt, cnt + 1)+-}++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: Monad m => Int -> Stream m Int+sourceUnfoldrM n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-+{-# INLINE sourceUnfoldrMN #-}+sourceUnfoldrMN :: Monad m => Int -> Int -> Stream m Int+sourceUnfoldrMN m n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + m+ then return Nothing+ else return (Just (cnt, cnt + 1))+-}++{-+{-# INLINE sourceFromEnum #-}+sourceFromEnum :: Monad m => Int -> Stream m Int+sourceFromEnum n = S.enumFromStepN n 1 value+-}++{-+{-# INLINE sourceFromFoldable #-}+sourceFromFoldable :: Int -> Stream m Int+sourceFromFoldable n = S.fromFoldable [n..n+value]+-}++{-+{-# INLINE sourceFromFoldableM #-}+sourceFromFoldableM :: S.MonadAsync m => Int -> Stream m Int+sourceFromFoldableM n = S.fromFoldableM (Prelude.fmap return [n..n+value])+-}++{-+{-# INLINE sourceFoldMapWith #-}+sourceFoldMapWith :: Int -> Stream m Int+sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]++{-# INLINE sourceFoldMapWithM #-}+sourceFoldMapWithM :: Monad m => Int -> Stream m Int+sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]+-}++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.drain+-- runStream = S.mapM_ (\_ -> return ())++{-+{-# INLINE mapM_ #-}+mapM_ :: Monad m => Stream m a -> m ()+mapM_ = S.mapM_ (\_ -> return ())+-}++{-# INLINE toNull #-}+toNull :: Monad m => Stream m Int -> m ()+toNull = runStream++{-# INLINE uncons #-}+uncons :: Monad m => Stream m Int -> m ()+uncons s = do+ r <- S.uncons s+ case r of+ Nothing -> return ()+ Just (_, t) -> uncons t++{-+{-# INLINE init #-}+init :: (Monad m, S.IsStream t) => t m a -> m ()+init s = do+ t <- S.init s+ P.mapM_ S.drain t++{-# INLINE tail #-}+tail :: (Monad m, S.IsStream t) => t m a -> m ()+tail s = S.tail s >>= P.mapM_ tail++{-# INLINE nullTail #-}+{-# INLINE headTail #-}+{-# INLINE zip #-}+nullTail, headTail, zip+ :: Monad m+ => Stream m Int -> m ()++nullTail s = do+ r <- S.null s+ when (not r) $ S.tail s >>= P.mapM_ nullTail++headTail s = do+ h <- S.head s+ when (isJust h) $ S.tail s >>= P.mapM_ headTail++{-# INLINE toList #-}+toList :: Monad m => Stream m Int -> m [Int]+toList = S.toList++{-# INLINE foldl #-}+foldl :: Monad m => Stream m Int -> m Int+foldl = S.foldl' (+) 0++{-# INLINE last #-}+last :: Monad m => Stream m Int -> m (Maybe Int)+last = S.last+-}++-------------------------------------------------------------------------------+-- Transformation+-------------------------------------------------------------------------------++{-+{-# INLINE transform #-}+transform :: Monad m => Stream m a -> m ()+transform = runStream++{-# INLINE composeN #-}+composeN+ :: Monad m+ => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()+composeN n f =+ case n of+ 1 -> transform . f+ 2 -> transform . f . f+ 3 -> transform . f . f . f+ 4 -> transform . f . f . f . f+ _ -> undefined+-}++{-+{-# INLINE scan #-}+{-# INLINE map #-}+{-# INLINE fmap #-}+{-# INLINE filterEven #-}+{-# INLINE filterAllOut #-}+{-# INLINE filterAllIn #-}+{-# INLINE takeOne #-}+{-# INLINE takeAll #-}+{-# INLINE takeWhileTrue #-}+{-# INLINE dropOne #-}+{-# INLINE dropAll #-}+{-# INLINE dropWhileTrue #-}+{-# INLINE dropWhileFalse #-}+{-# INLINE foldlS #-}+{-# INLINE concatMap #-}+scan, map, fmap, filterEven, filterAllOut,+ filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropOne,+ dropWhileTrue, dropWhileFalse, foldlS, concatMap+ :: Monad m+ => Int -> Stream m Int -> m ()++{-# INLINE mapM #-}+{-# INLINE mapMSerial #-}+{-# INLINE intersperse #-}+mapM, mapMSerial, intersperse+ :: S.MonadAsync m => Int -> Stream m Int -> m ()++scan n = composeN n $ S.scanl' (+) 0+map n = composeN n $ P.fmap (+1)+fmap n = composeN n $ P.fmap (+1)+mapM n = composeN n $ S.mapM return+mapMSerial n = composeN n $ S.mapMSerial return+filterEven n = composeN n $ S.filter even+filterAllOut n = composeN n $ S.filter (> maxValue)+filterAllIn n = composeN n $ S.filter (<= maxValue)+takeOne n = composeN n $ S.take 1+takeAll n = composeN n $ S.take maxValue+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)+dropOne n = composeN n $ S.drop 1+dropAll n = composeN n $ S.drop maxValue+dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)+dropWhileFalse n = composeN n $ S.dropWhile (<= 1)+foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil+-- We use a (sqrt n) element stream as source and then concat the same stream+-- for each element to produce an n element stream.+concatMap n = composeN n $ (\s -> S.concatMap (\_ -> s) s)+intersperse n = composeN n $ S.intersperse maxValue++-------------------------------------------------------------------------------+-- Iteration+-------------------------------------------------------------------------------++iterStreamLen, maxIters :: Int+iterStreamLen = 10+maxIters = 10000++{-# INLINE iterateSource #-}+iterateSource+ :: S.MonadAsync m+ => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)+ where+ f (0 :: Int) m = g m+ f x m = g (f (x P.- 1) m)++{-# INLINE iterateMapM #-}+{-# INLINE iterateScan #-}+{-# INLINE iterateFilterEven #-}+{-# INLINE iterateTakeAll #-}+{-# INLINE iterateDropOne #-}+{-# INLINE iterateDropWhileFalse #-}+{-# INLINE iterateDropWhileTrue #-}+iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,+ iterateDropWhileFalse, iterateDropWhileTrue+ :: S.MonadAsync m+ => Int -> Stream m Int++-- this is quadratic+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)+iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))+ (maxIters `div` 10)++iterateMapM = iterateSource (S.mapM return) maxIters+iterateFilterEven = iterateSource (S.filter even) maxIters+iterateTakeAll = iterateSource (S.take maxValue) maxIters+iterateDropOne = iterateSource (S.drop 1) maxIters+iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters++-------------------------------------------------------------------------------+-- Zipping and concat+-------------------------------------------------------------------------------++zip src = transform $ S.zipWith (,) src src++{-# INLINE concatMapRepl4xN #-}+concatMapRepl4xN :: Monad m => Stream m Int -> m ()+concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)++-------------------------------------------------------------------------------+-- Mixed Composition+-------------------------------------------------------------------------------++{-# INLINE scanMap #-}+{-# INLINE dropMap #-}+{-# INLINE dropScan #-}+{-# INLINE takeDrop #-}+{-# INLINE takeScan #-}+{-# INLINE takeMap #-}+{-# INLINE filterDrop #-}+{-# INLINE filterTake #-}+{-# INLINE filterScan #-}+{-# INLINE filterMap #-}+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,+ filterTake, filterScan, filterMap+ :: Monad m => Int -> Stream m Int -> m ()++scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1+takeDrop n = composeN n $ S.drop 1 . S.take maxValue+takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue+takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)+filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++-------------------------------------------------------------------------------+-- Nested Composition+-------------------------------------------------------------------------------++{-# INLINE toNullApNested #-}+toNullApNested :: Monad m => Stream m Int -> m ()+toNullApNested s = runStream $ do+ (+) <$> s <*> s++{-# INLINE toNullNested #-}+toNullNested :: Monad m => Stream m Int -> m ()+toNullNested s = runStream $ do+ x <- s+ y <- s+ return $ x + y++{-# INLINE toNullNested3 #-}+toNullNested3 :: Monad m => Stream m Int -> m ()+toNullNested3 s = runStream $ do+ x <- s+ y <- s+ z <- s+ return $ x + y + z++{-# INLINE filterAllOutNested #-}+filterAllOutNested+ :: Monad m+ => Stream m Int -> m ()+filterAllOutNested str = runStream $ do+ x <- str+ y <- str+ let s = x + y+ if s < 0+ then return s+ else S.nil++{-# INLINE filterAllInNested #-}+filterAllInNested+ :: Monad m+ => Stream m Int -> m ()+filterAllInNested str = runStream $ do+ x <- str+ y <- str+ let s = x + y+ if s > 0+ then return s+ else S.nil++-------------------------------------------------------------------------------+-- Nested Composition Pure lists+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldrList #-}+sourceUnfoldrList :: Int -> Int -> [Int]+sourceUnfoldrList maxval n = List.unfoldr step n+ where+ step cnt =+ if cnt > n + maxval+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE toNullApNestedList #-}+toNullApNestedList :: [Int] -> [Int]+toNullApNestedList s = (+) <$> s <*> s++{-# INLINE toNullNestedList #-}+toNullNestedList :: [Int] -> [Int]+toNullNestedList s = do+ x <- s+ y <- s+ return $ x + y++{-# INLINE toNullNestedList3 #-}+toNullNestedList3 :: [Int] -> [Int]+toNullNestedList3 s = do+ x <- s+ y <- s+ z <- s+ return $ x + y + z++{-# INLINE filterAllOutNestedList #-}+filterAllOutNestedList :: [Int] -> [Int]+filterAllOutNestedList str = do+ x <- str+ y <- str+ let s = x + y+ if s < 0+ then return s+ else []++{-# INLINE filterAllInNestedList #-}+filterAllInNestedList :: [Int] -> [Int]+filterAllInNestedList str = do+ x <- str+ y <- str+ let s = x + y+ if s > 0+ then return s+ else []+-}++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++o_1_space :: [Benchmark]+o_1_space =+ [ bgroup "streamDK"+ [ bgroup "generation"+ [ benchFold "unfoldr" toNull sourceUnfoldr+ , benchFold "unfoldrM" toNull sourceUnfoldrM+ ]+ , bgroup "elimination"+ [ benchFold "toNull" toNull sourceUnfoldrM+ , benchFold "uncons" uncons sourceUnfoldrM+ ]+ ]+ ]
+ benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs view
@@ -0,0 +1,609 @@+-- |+-- Module : Streamly.Benchmark.Data.Stream.StreamK+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Streamly.Benchmark.Data.Stream.StreamK+ (+ o_1_space+ , o_n_stack+ , o_n_heap+ , o_n_space+ , o_1_space_list+ )+where++import Control.Monad (when)+import Data.Maybe (isJust)+import Prelude+ (Monad, Int, (+), ($), (.), return, even, (>), (<=), div,+ subtract, undefined, Maybe(..), not, (>>=),+ maxBound, flip, (<$>), (<*>), round, (/), (**), (<), foldr, fmap)+import System.Random (randomRIO)+import qualified Prelude as P+import qualified Data.List as List++import qualified Streamly.Internal.Data.Stream.StreamK as S+import qualified Streamly.Internal.Data.Stream.Prelude as SP+import qualified Streamly.Internal.Data.SVar as S++import Streamly.Benchmark.Common (benchFold)+import Gauge (bench, nfIO, bgroup, Benchmark)++value, value2, value3, value16, maxValue :: Int+value = 100000+value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop+value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop+value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop+maxValue = value++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++{-# INLINE toNull #-}+{-# INLINE uncons #-}+{-# INLINE nullTail #-}+{-# INLINE headTail #-}+{-# INLINE zip #-}+toNull, uncons, nullTail, headTail, zip+ :: Monad m+ => Stream m Int -> m ()++{-# INLINE toList #-}+toList :: Monad m => Stream m Int -> m [Int]+{-# INLINE foldl #-}+foldl :: Monad m => Stream m Int -> m Int+{-# INLINE last #-}+last :: Monad m => Stream m Int -> m (Maybe Int)++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++type Stream m a = S.Stream m a++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: Int -> Stream m Int+sourceUnfoldr n = S.unfoldr step n+ where+ step cnt =+ if cnt > n + value+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrN #-}+sourceUnfoldrN :: Int -> Int -> Stream m Int+sourceUnfoldrN m n = S.unfoldr step n+ where+ step cnt =+ if cnt > n + m+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: S.MonadAsync m => Int -> Stream m Int+sourceUnfoldrM n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE sourceUnfoldrMN #-}+sourceUnfoldrMN :: S.MonadAsync m => Int -> Int -> Stream m Int+sourceUnfoldrMN m n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + m+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE sourceFromFoldable #-}+sourceFromFoldable :: Int -> Stream m Int+sourceFromFoldable n = S.fromFoldable [n..n+value]++{-# INLINE sourceFromFoldableM #-}+sourceFromFoldableM :: S.MonadAsync m => Int -> Stream m Int+sourceFromFoldableM n =+ Prelude.foldr S.consM S.nil (Prelude.fmap return [n..n+value])++{-# INLINE sourceFoldMapWith #-}+sourceFoldMapWith :: Int -> Stream m Int+sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]++{-# INLINE sourceFoldMapWithM #-}+sourceFoldMapWithM :: Monad m => Int -> Stream m Int+sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.drain+-- runStream = S.mapM_ (\_ -> return ())++{-# INLINE mapM_ #-}+mapM_ :: Monad m => Stream m a -> m ()+mapM_ = S.mapM_ (\_ -> return ())++toNull = runStream+uncons s = do+ r <- S.uncons s+ case r of+ Nothing -> return ()+ Just (_, t) -> uncons t++{-# INLINE init #-}+init :: (Monad m, S.IsStream t) => t m a -> m ()+init s = do+ t <- S.init s+ P.mapM_ S.drain t++{-# INLINE tail #-}+tail :: (Monad m, S.IsStream t) => t m a -> m ()+tail s = S.tail s >>= P.mapM_ tail++nullTail s = do+ r <- S.null s+ when (not r) $ S.tail s >>= P.mapM_ nullTail++headTail s = do+ h <- S.head s+ when (isJust h) $ S.tail s >>= P.mapM_ headTail++toList = S.toList+foldl = S.foldl' (+) 0+last = S.last++-------------------------------------------------------------------------------+-- Transformation+-------------------------------------------------------------------------------++{-# INLINE transform #-}+transform :: Monad m => Stream m a -> m ()+transform = runStream++{-# INLINE composeN #-}+composeN+ :: Monad m+ => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()+composeN n f =+ case n of+ 1 -> transform . f+ 2 -> transform . f . f+ 3 -> transform . f . f . f+ 4 -> transform . f . f . f . f+ _ -> undefined++{-# INLINE scan #-}+{-# INLINE map #-}+{-# INLINE fmapK #-}+{-# INLINE filterEven #-}+{-# INLINE filterAllOut #-}+{-# INLINE filterAllIn #-}+{-# INLINE _takeOne #-}+{-# INLINE takeAll #-}+{-# INLINE takeWhileTrue #-}+{-# INLINE dropOne #-}+{-# INLINE dropAll #-}+{-# INLINE dropWhileTrue #-}+{-# INLINE dropWhileFalse #-}+{-# INLINE foldrS #-}+{-# INLINE foldlS #-}+{-# INLINE concatMap #-}+scan, map, fmapK, filterEven, filterAllOut,+ filterAllIn, _takeOne, takeAll, takeWhileTrue, dropAll, dropOne,+ dropWhileTrue, dropWhileFalse, foldrS, foldlS, concatMap+ :: Monad m+ => Int -> Stream m Int -> m ()++{-# INLINE mapM #-}+{-# INLINE mapMSerial #-}+{-# INLINE intersperse #-}+mapM, mapMSerial, intersperse+ :: S.MonadAsync m => Int -> Stream m Int -> m ()++scan n = composeN n $ S.scanl' (+) 0+map n = composeN n $ P.fmap (+1)+fmapK n = composeN n $ P.fmap (+1)+mapM n = composeN n $ S.mapM return+mapMSerial n = composeN n $ S.mapMSerial return+filterEven n = composeN n $ S.filter even+filterAllOut n = composeN n $ S.filter (> maxValue)+filterAllIn n = composeN n $ S.filter (<= maxValue)+_takeOne n = composeN n $ S.take 1+takeAll n = composeN n $ S.take maxValue+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)+dropOne n = composeN n $ S.drop 1+dropAll n = composeN n $ S.drop maxValue+dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)+dropWhileFalse n = composeN n $ S.dropWhile (<= 1)+foldrS n = composeN n $ S.foldrS S.cons S.nil+foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil+-- We use a (sqrt n) element stream as source and then concat the same stream+-- for each element to produce an n element stream.+concatMap n = composeN n $ (\s -> S.concatMap (\_ -> s) s)+intersperse n = composeN n $ S.intersperse maxValue++-------------------------------------------------------------------------------+-- Iteration+-------------------------------------------------------------------------------++iterStreamLen, maxIters :: Int+iterStreamLen = 10+maxIters = 10000++{-# INLINE iterateSource #-}+iterateSource+ :: S.MonadAsync m+ => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)+ where+ f (0 :: Int) m = g m+ f x m = g (f (x P.- 1) m)++{-# INLINE iterateMapM #-}+{-# INLINE iterateScan #-}+{-# INLINE iterateFilterEven #-}+{-# INLINE iterateTakeAll #-}+{-# INLINE iterateDropOne #-}+{-# INLINE iterateDropWhileFalse #-}+{-# INLINE iterateDropWhileTrue #-}+iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,+ iterateDropWhileFalse, iterateDropWhileTrue+ :: S.MonadAsync m+ => Int -> Stream m Int++-- this is quadratic+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)+iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))+ (maxIters `div` 10)++iterateMapM = iterateSource (S.mapM return) maxIters+iterateFilterEven = iterateSource (S.filter even) maxIters+iterateTakeAll = iterateSource (S.take maxValue) maxIters+iterateDropOne = iterateSource (S.drop 1) maxIters+iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters++-------------------------------------------------------------------------------+-- Zipping and concat+-------------------------------------------------------------------------------++zip src = transform $ S.zipWith (,) src src++{-# INLINE concatMapRepl4xN #-}+concatMapRepl4xN :: Monad m => Stream m Int -> m ()+concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)++-------------------------------------------------------------------------------+-- Mixed Composition+-------------------------------------------------------------------------------++{-# INLINE scanMap #-}+{-# INLINE dropMap #-}+{-# INLINE dropScan #-}+{-# INLINE takeDrop #-}+{-# INLINE takeScan #-}+{-# INLINE takeMap #-}+{-# INLINE filterDrop #-}+{-# INLINE filterTake #-}+{-# INLINE filterScan #-}+{-# INLINE filterMap #-}+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,+ filterTake, filterScan, filterMap+ :: Monad m => Int -> Stream m Int -> m ()++scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1+takeDrop n = composeN n $ S.drop 1 . S.take maxValue+takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue+takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)+filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++-------------------------------------------------------------------------------+-- Nested Composition+-------------------------------------------------------------------------------++{-# INLINE toNullApNested #-}+toNullApNested :: Monad m => Stream m Int -> m ()+toNullApNested s = runStream $ do+ (+) <$> s <*> s++{-# INLINE toNullNested #-}+toNullNested :: Monad m => Stream m Int -> m ()+toNullNested s = runStream $ do+ x <- s+ y <- s+ return $ x + y++{-# INLINE toNullNested3 #-}+toNullNested3 :: Monad m => Stream m Int -> m ()+toNullNested3 s = runStream $ do+ x <- s+ y <- s+ z <- s+ return $ x + y + z++{-# INLINE filterAllOutNested #-}+filterAllOutNested+ :: Monad m+ => Stream m Int -> m ()+filterAllOutNested str = runStream $ do+ x <- str+ y <- str+ let s = x + y+ if s < 0+ then return s+ else S.nil++{-# INLINE filterAllInNested #-}+filterAllInNested+ :: Monad m+ => Stream m Int -> m ()+filterAllInNested str = runStream $ do+ x <- str+ y <- str+ let s = x + y+ if s > 0+ then return s+ else S.nil++-------------------------------------------------------------------------------+-- Nested Composition Pure lists+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldrList #-}+sourceUnfoldrList :: Int -> Int -> [Int]+sourceUnfoldrList maxval n = List.unfoldr step n+ where+ step cnt =+ if cnt > n + maxval+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE toNullApNestedList #-}+toNullApNestedList :: [Int] -> [Int]+toNullApNestedList s = (+) <$> s <*> s++{-# INLINE toNullNestedList #-}+toNullNestedList :: [Int] -> [Int]+toNullNestedList s = do+ x <- s+ y <- s+ return $ x + y++{-# INLINE toNullNestedList3 #-}+toNullNestedList3 :: [Int] -> [Int]+toNullNestedList3 s = do+ x <- s+ y <- s+ z <- s+ return $ x + y + z++{-# INLINE filterAllOutNestedList #-}+filterAllOutNestedList :: [Int] -> [Int]+filterAllOutNestedList str = do+ x <- str+ y <- str+ let s = x + y+ if s < 0+ then return s+ else []++{-# INLINE filterAllInNestedList #-}+filterAllInNestedList :: [Int] -> [Int]+filterAllInNestedList str = do+ x <- str+ y <- str+ let s = x + y+ if s > 0+ then return s+ else []++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++o_1_space :: [Benchmark]+o_1_space =+ [ bgroup "streamK"+ [ bgroup "generation"+ [ benchFold "unfoldr" toNull sourceUnfoldr+ , benchFold "unfoldrM" toNull sourceUnfoldrM++ , benchFold "fromFoldable" toNull sourceFromFoldable+ , benchFold "fromFoldableM" toNull sourceFromFoldableM++ -- appends+ , benchFold "foldMapWith" toNull sourceFoldMapWith+ , benchFold "foldMapWithM" toNull sourceFoldMapWithM+ ]+ , bgroup "elimination"+ [ benchFold "toNull" toNull sourceUnfoldrM+ , benchFold "mapM_" mapM_ sourceUnfoldrM+ , benchFold "uncons" uncons sourceUnfoldrM+ , benchFold "init" init sourceUnfoldrM+ , benchFold "foldl'" foldl sourceUnfoldrM+ , benchFold "last" last sourceUnfoldrM+ ]+ , bgroup "nested"+ [ benchFold "toNullAp" toNullApNested (sourceUnfoldrMN value2)+ , benchFold "toNull" toNullNested (sourceUnfoldrMN value2)+ , benchFold "toNull3" toNullNested3 (sourceUnfoldrMN value3)+ , benchFold "filterAllIn" filterAllInNested (sourceUnfoldrMN value2)+ , benchFold "filterAllOut" filterAllOutNested (sourceUnfoldrMN value2)+ , benchFold "toNullApPure" toNullApNested (sourceUnfoldrN value2)+ , benchFold "toNullPure" toNullNested (sourceUnfoldrN value2)+ , benchFold "toNull3Pure" toNullNested3 (sourceUnfoldrN value3)+ , benchFold "filterAllInPure" filterAllInNested (sourceUnfoldrN value2)+ , benchFold "filterAllOutPure" filterAllOutNested (sourceUnfoldrN value2)+ ]+ , bgroup "transformation"+ [ benchFold "foldrS" (foldrS 1) sourceUnfoldrM+ , benchFold "scan" (scan 1) sourceUnfoldrM+ , benchFold "map" (map 1) sourceUnfoldrM+ , benchFold "fmap" (fmapK 1) sourceUnfoldrM+ , benchFold "mapM" (mapM 1) sourceUnfoldrM+ , benchFold "mapMSerial" (mapMSerial 1) sourceUnfoldrM+ -- , benchFoldSrcK "concatMap" concatMap+ , benchFold "concatMapNxN" (concatMap 1) (sourceUnfoldrMN value2)+ , benchFold "concatMapPureNxN" (concatMap 1) (sourceUnfoldrN value2)+ , benchFold "concatMapRepl4xN" concatMapRepl4xN+ (sourceUnfoldrMN (value `div` 4))+ ]+ , bgroup "transformationX4"+ [ benchFold "scan" (scan 4) sourceUnfoldrM+ , benchFold "map" (map 4) sourceUnfoldrM+ , benchFold "fmap" (fmapK 4) sourceUnfoldrM+ , benchFold "mapM" (mapM 4) sourceUnfoldrM+ , benchFold "mapMSerial" (mapMSerial 4) sourceUnfoldrM+ -- XXX this is horribly slow+ -- , benchFold "concatMap" (concatMap 4) (sourceUnfoldrMN value16)+ ]+ , bgroup "filtering"+ [ benchFold "filter-even" (filterEven 1) sourceUnfoldrM+ , benchFold "filter-all-out" (filterAllOut 1) sourceUnfoldrM+ , benchFold "filter-all-in" (filterAllIn 1) sourceUnfoldrM+ , benchFold "take-all" (takeAll 1) sourceUnfoldrM+ , benchFold "takeWhile-true" (takeWhileTrue 1) sourceUnfoldrM+ , benchFold "drop-one" (dropOne 1) sourceUnfoldrM+ , benchFold "drop-all" (dropAll 1) sourceUnfoldrM+ , benchFold "dropWhile-true" (dropWhileTrue 1) sourceUnfoldrM+ , benchFold "dropWhile-false" (dropWhileFalse 1) sourceUnfoldrM+ ]+ , bgroup "filteringX4"+ [ benchFold "filter-even" (filterEven 4) sourceUnfoldrM+ , benchFold "filter-all-out" (filterAllOut 4) sourceUnfoldrM+ , benchFold "filter-all-in" (filterAllIn 4) sourceUnfoldrM+ , benchFold "take-all" (takeAll 4) sourceUnfoldrM+ , benchFold "takeWhile-true" (takeWhileTrue 4) sourceUnfoldrM+ , benchFold "drop-one" (dropOne 4) sourceUnfoldrM+ , benchFold "drop-all" (dropAll 4) sourceUnfoldrM+ , benchFold "dropWhile-true" (dropWhileTrue 4) sourceUnfoldrM+ , benchFold "dropWhile-false" (dropWhileFalse 4) sourceUnfoldrM+ ]+ , bgroup "zipping"+ [ benchFold "zip" zip sourceUnfoldrM+ ]+ , bgroup "mixed"+ [ benchFold "scan-map" (scanMap 1) sourceUnfoldrM+ , benchFold "drop-map" (dropMap 1) sourceUnfoldrM+ , benchFold "drop-scan" (dropScan 1) sourceUnfoldrM+ , benchFold "take-drop" (takeDrop 1) sourceUnfoldrM+ , benchFold "take-scan" (takeScan 1) sourceUnfoldrM+ , benchFold "take-map" (takeMap 1) sourceUnfoldrM+ , benchFold "filter-drop" (filterDrop 1) sourceUnfoldrM+ , benchFold "filter-take" (filterTake 1) sourceUnfoldrM+ , benchFold "filter-scan" (filterScan 1) sourceUnfoldrM+ , benchFold "filter-map" (filterMap 1) sourceUnfoldrM+ ]+ , bgroup "mixedX2"+ [ benchFold "scan-map" (scanMap 2) sourceUnfoldrM+ , benchFold "drop-map" (dropMap 2) sourceUnfoldrM+ , benchFold "drop-scan" (dropScan 2) sourceUnfoldrM+ , benchFold "take-drop" (takeDrop 2) sourceUnfoldrM+ , benchFold "take-scan" (takeScan 2) sourceUnfoldrM+ , benchFold "take-map" (takeMap 2) sourceUnfoldrM+ , benchFold "filter-drop" (filterDrop 2) sourceUnfoldrM+ , benchFold "filter-take" (filterTake 2) sourceUnfoldrM+ , benchFold "filter-scan" (filterScan 2) sourceUnfoldrM+ , benchFold "filter-map" (filterMap 2) sourceUnfoldrM+ ]+ , bgroup "mixedX4"+ [ benchFold "scan-map" (scanMap 4) sourceUnfoldrM+ , benchFold "drop-map" (dropMap 4) sourceUnfoldrM+ , benchFold "drop-scan" (dropScan 4) sourceUnfoldrM+ , benchFold "take-drop" (takeDrop 4) sourceUnfoldrM+ , benchFold "take-scan" (takeScan 4) sourceUnfoldrM+ , benchFold "take-map" (takeMap 4) sourceUnfoldrM+ , benchFold "filter-drop" (filterDrop 4) sourceUnfoldrM+ , benchFold "filter-take" (filterTake 4) sourceUnfoldrM+ , benchFold "filter-scan" (filterScan 4) sourceUnfoldrM+ , benchFold "filter-map" (filterMap 4) sourceUnfoldrM+ ]+ ]+ ]++o_n_heap :: [Benchmark]+o_n_heap =+ [ bgroup "streamK"+ [ bgroup "transformation"+ [ benchFold "foldlS" (foldlS 1) sourceUnfoldrM+ ]+ ]+ ]++{-# INLINE benchK #-}+benchK :: P.String -> (Int -> Stream P.IO Int) -> Benchmark+benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= toNull . f++o_n_stack :: [Benchmark]+o_n_stack =+ [ bgroup "streamK"+ [ bgroup "elimination"+ [ benchFold "tail" tail sourceUnfoldrM+ , benchFold "nullTail" nullTail sourceUnfoldrM+ , benchFold "headTail" headTail sourceUnfoldrM+ ]+ , bgroup "transformation"+ [+ -- XXX why do these need so much stack+ benchFold "intersperse" (intersperse 1) (sourceUnfoldrMN value2)+ , benchFold "interspersePure" (intersperse 1) (sourceUnfoldrN value2)+ ]+ , bgroup "transformationX4"+ [+ benchFold "intersperse" (intersperse 4) (sourceUnfoldrMN value16)+ ]+ , bgroup "iterated"+ [ benchK "mapM" iterateMapM+ , benchK "scan(1/10)" iterateScan+ , benchK "filterEven" iterateFilterEven+ , benchK "takeAll" iterateTakeAll+ , benchK "dropOne" iterateDropOne+ , benchK "dropWhileFalse(1/10)" iterateDropWhileFalse+ , benchK "dropWhileTrue" iterateDropWhileTrue+ ]+ ]+ ]++o_n_space :: [Benchmark]+o_n_space =+ [ bgroup "streamK"+ [ bgroup "elimination"+ [ benchFold "toList" toList sourceUnfoldrM+ ]+ ]+ ]++{-# INLINE benchList #-}+benchList :: P.String -> ([Int] -> [Int]) -> (Int -> [Int]) -> Benchmark+benchList name run f = bench name $ nfIO $ randomRIO (1,1) >>= return . run . f++o_1_space_list :: [Benchmark]+o_1_space_list =+ [ bgroup "list"+ [ bgroup "elimination"+ [ benchList "last" (\xs -> [List.last xs]) (sourceUnfoldrList value)+ ]+ , bgroup "nested"+ [ benchList "toNullAp" toNullApNestedList (sourceUnfoldrList value2)+ , benchList "toNull" toNullNestedList (sourceUnfoldrList value2)+ , benchList "toNull3" toNullNestedList3 (sourceUnfoldrList value3)+ , benchList "filterAllIn" filterAllInNestedList (sourceUnfoldrList value2)+ , benchList "filterAllOut" filterAllOutNestedList (sourceUnfoldrList value2)+ ]+ ]+ ]
+ benchmark/Streamly/Benchmark/Data/Unfold.hs view
@@ -0,0 +1,77 @@+-- |+-- Module : Streamly.Benchmark.Data.Fold+-- Copyright : (c) 2018 Composewell+--+-- License : MIT+-- Maintainer : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}++module Main (main) where++import Control.DeepSeq (NFData(..))++import System.Random (randomRIO)++import Gauge++import Prelude hiding (concat)++import Streamly.Benchmark.Common+import Streamly.Benchmark.Data.NestedUnfoldOps++{-# INLINE benchIO #-}+benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark+benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f++-------------------------------------------------------------------------------+-- Stream folds+-------------------------------------------------------------------------------++o_1_space_serial_outerProductUnfolds :: Int -> [Benchmark]+o_1_space_serial_outerProductUnfolds value =+ [ bgroup+ "serially"+ [ bgroup+ "outer-product-unfolds"+ [ benchIO "toNull" $ toNull value+ , benchIO "toNull3" $ toNull3 value+ , benchIO "concat" $ concat value+ , benchIO "filterAllOut" $ filterAllOut value+ , benchIO "filterAllIn" $ filterAllIn value+ , benchIO "filterSome" $ filterSome value+ , benchIO "breakAfterSome" $ breakAfterSome value+ ]+ ]+ ]+++o_n_space_serial_outerProductUnfolds :: Int -> [Benchmark]+o_n_space_serial_outerProductUnfolds value =+ [ bgroup+ "serially"+ [ bgroup+ "outer-product-unfolds"+ [ benchIO "toList" $ toList value+ , benchIO "toListSome" $ toListSome value+ ]+ ]+ ]++-------------------------------------------------------------------------------+-- Driver+-------------------------------------------------------------------------------++main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)+ where+ allBenchmarks value =+ [ bgroup+ "o-1-space"+ [bgroup "unfold" (o_1_space_serial_outerProductUnfolds value)]+ , bgroup+ "o-n-space"+ [bgroup "unfold" (o_n_space_serial_outerProductUnfolds value)]+ ]
benchmark/Streamly/Benchmark/FileIO/Stream.hs view
@@ -57,10 +57,12 @@ , decodeUtf8Lax , copyCodecUtf8Lenient , chunksOfSum+ , splitParseChunksOfSum , chunksOf , chunksOfD , splitOn , splitOnSuffix+ , splitParseSepBy , wordsBy , splitOnSeq , splitOnSeqUtf8@@ -86,6 +88,7 @@ import qualified Streamly.Internal.Data.Unicode.Stream as IUS import qualified Streamly.Internal.Memory.Unicode.Array as IUA import qualified Streamly.Internal.Data.Unfold as IUF+import qualified Streamly.Internal.Data.Parser as PR import qualified Streamly.Internal.Prelude as IP import qualified Streamly.Internal.Data.Stream.StreamD as D @@ -301,7 +304,7 @@ catHandle :: Handle -> Handle -> IO () catHandle devNull inh = let handler (_e :: SomeException) = hClose inh >> return 10- readEx = IUF.handle (IUF.singleton handler) FH.read+ readEx = IUF.handle (IUF.singletonM handler) FH.read in S.fold (FH.write devNull) $ S.unfold readEx inh #ifdef INSPECTION@@ -442,6 +445,11 @@ inspect $ 'chunksOfD `hasNoType` ''D.ConcatMapUState #endif +{-# INLINE splitParseChunksOfSum #-}+splitParseChunksOfSum :: Int -> Handle -> IO Int+splitParseChunksOfSum n inh =+ S.length $ IP.splitParse (PR.take n FL.sum) (S.unfold FH.read inh)+ {-# INLINE linesUnlinesCopy #-} linesUnlinesCopy :: Handle -> Handle -> IO () linesUnlinesCopy inh outh =@@ -599,6 +607,13 @@ inspect $ 'splitOnSuffix `hasNoType` ''AT.FlattenState inspect $ 'splitOnSuffix `hasNoType` ''D.ConcatMapUState #endif++-- | Split on line feed.+{-# INLINE splitParseSepBy #-}+splitParseSepBy :: Handle -> IO Int+splitParseSepBy inh =+ (S.length $ IP.splitParse (PR.sliceSepBy (== lf) FL.drain)+ (S.unfold FH.read inh)) -- >>= print -- | Words by space {-# INLINE wordsBy #-}
+ benchmark/Streamly/Benchmark/Memory/Array.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP #-}+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Control.DeepSeq (NFData(..), deepseq)+import Foreign.Storable (Storable(..))+import System.Random (randomRIO)++import qualified GHC.Exts as GHC++import qualified Streamly.Benchmark.Memory.ArrayOps as Ops+import qualified Streamly.Internal.Memory.Array as IA+import qualified Streamly.Memory.Array as A+import qualified Streamly.Prelude as S++import Gauge++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++{-# INLINE benchPure #-}+benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark+benchPure name src f = bench name $ nfIO $+ randomRIO (1,1) >>= return . f . src++-- Drain a source that generates a pure array+{-# INLINE benchPureSrc #-}+benchPureSrc :: (NFData a, Storable a)+ => String -> (Int -> Ops.Stream a) -> Benchmark+benchPureSrc name src = benchPure name src id++{-# INLINE benchIO #-}+benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark+benchIO name src f = bench name $ nfIO $+ randomRIO (1,1) >>= src >>= return . f++-- Drain a source that generates an array in the IO monad+{-# INLINE benchIOSrc #-}+benchIOSrc :: (NFData a, Storable a)+ => String -> (Int -> IO (Ops.Stream a)) -> Benchmark+benchIOSrc name src = benchIO name src id++{-# INLINE benchPureSink #-}+benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark+benchPureSink name f = benchIO name Ops.sourceIntFromTo f++{-# INLINE benchIO' #-}+benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark+benchIO' name src f = bench name $ nfIO $+ randomRIO (1,1) >>= src >>= f++{-# INLINE benchIOSink #-}+benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark+benchIOSink name f = benchIO' name Ops.sourceIntFromTo f++mkString :: String+mkString = "[1" ++ concat (replicate Ops.value ",1") ++ "]"++main :: IO ()+main =+ defaultMain+ [ bgroup "array"+ [ bgroup "generation"+ [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo+ , benchIOSrc "write . intFromTo" Ops.sourceIntFromToFromStream+ , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList+ , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr+ , benchIOSrc "writeN . fromList" Ops.sourceFromList+ , benchPureSrc "writeN . IsList.fromList" Ops.sourceIsList+ , benchPureSrc "writeN . IsString.fromString" Ops.sourceIsString+ , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString)+ , benchPureSink "show" Ops.showInstance+ ]+ , bgroup "elimination"+ [ benchPureSink "id" id+ -- , benchPureSink "eqBy" Ops.eqBy+ , benchPureSink "==" Ops.eqInstance+ , benchPureSink "/=" Ops.eqInstanceNotEq+ {-+ , benchPureSink "cmpBy" Ops.cmpBy+ -}+ , benchPureSink "<" Ops.ordInstance+ , benchPureSink "min" Ops.ordInstanceMin+ -- length is used to check for foldr/build fusion+ , benchPureSink "length . IsList.toList" (length . GHC.toList)+ , benchIOSink "foldl'" Ops.pureFoldl'+ , benchIOSink "read" (S.drain . S.unfold A.read)+ , benchIOSink "toStreamRev" (S.drain . IA.toStreamRev)+#ifdef DEVBUILD+ , benchPureSink "foldable/foldl'" Ops.foldableFoldl'+ , benchPureSink "foldable/sum" Ops.foldableSum+ -- , benchPureSinkIO "traversable/mapM" Ops.traversableMapM+#endif+ ]++ {-+ [ benchPureSink "uncons" Ops.uncons+ , benchPureSink "toNull" $ Ops.toNull serially+ , benchPureSink "mapM_" Ops.mapM_++ , benchPureSink "init" Ops.init+ , benchPureSink "tail" Ops.tail+ , benchPureSink "nullHeadTail" Ops.nullHeadTail++ -- this is too low and causes all benchmarks reported in ns+ -- , benchPureSink "head" Ops.head+ , benchPureSink "last" Ops.last+ -- , benchPureSink "lookup" Ops.lookup+ , benchPureSink "find" Ops.find+ , benchPureSink "findIndex" Ops.findIndex+ , benchPureSink "elemIndex" Ops.elemIndex++ -- this is too low and causes all benchmarks reported in ns+ -- , benchPureSink "null" Ops.null+ , benchPureSink "elem" Ops.elem+ , benchPureSink "notElem" Ops.notElem+ , benchPureSink "all" Ops.all+ , benchPureSink "any" Ops.any+ , benchPureSink "and" Ops.and+ , benchPureSink "or" Ops.or++ , benchPureSink "length" Ops.length+ , benchPureSink "sum" Ops.sum+ , benchPureSink "product" Ops.product++ , benchPureSink "maximumBy" Ops.maximumBy+ , benchPureSink "maximum" Ops.maximum+ , benchPureSink "minimumBy" Ops.minimumBy+ , benchPureSink "minimum" Ops.minimum++ , benchPureSink "toList" Ops.toList+ , benchPureSink "toRevList" Ops.toRevList+ ]+ -}+ , bgroup "transformation"+ [ benchIOSink "scanl'" (Ops.scanl' 1)+ , benchIOSink "scanl1'" (Ops.scanl1' 1)+ , benchIOSink "map" (Ops.map 1)+ {-+ , benchPureSink "fmap" (Ops.fmap 1)+ , benchPureSink "mapM" (Ops.mapM serially 1)+ , benchPureSink "mapMaybe" (Ops.mapMaybe 1)+ , benchPureSink "mapMaybeM" (Ops.mapMaybeM 1)+ , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->+ Ops.sequence serially (Ops.sourceUnfoldrMAction n)+ , benchPureSink "findIndices" (Ops.findIndices 1)+ , benchPureSink "elemIndices" (Ops.elemIndices 1)+ , benchPureSink "reverse" (Ops.reverse 1)+ , benchPureSink "foldrS" (Ops.foldrS 1)+ , benchPureSink "foldrSMap" (Ops.foldrSMap 1)+ , benchPureSink "foldrT" (Ops.foldrT 1)+ , benchPureSink "foldrTMap" (Ops.foldrTMap 1)+ -}+ ]+ , bgroup "transformationX4"+ [ benchIOSink "scanl'" (Ops.scanl' 4)+ , benchIOSink "scanl1'" (Ops.scanl1' 4)+ , benchIOSink "map" (Ops.map 4)+ {-+ , benchPureSink "fmap" (Ops.fmap 4)+ , benchPureSink "mapM" (Ops.mapM serially 4)+ , benchPureSink "mapMaybe" (Ops.mapMaybe 4)+ , benchPureSink "mapMaybeM" (Ops.mapMaybeM 4)+ -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->+ -- Ops.sequence serially (Ops.sourceUnfoldrMAction n)+ , benchPureSink "findIndices" (Ops.findIndices 4)+ , benchPureSink "elemIndices" (Ops.elemIndices 4)+ -}+ ]+ {-+ , bgroup "filtering"+ [ benchPureSink "filter-even" (Ops.filterEven 1)+ , benchPureSink "filter-all-out" (Ops.filterAllOut 1)+ , benchPureSink "filter-all-in" (Ops.filterAllIn 1)+ , benchPureSink "take-all" (Ops.takeAll 1)+ , benchPureSink "takeWhile-true" (Ops.takeWhileTrue 1)+ --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 1)+ , benchPureSink "drop-one" (Ops.dropOne 1)+ , benchPureSink "drop-all" (Ops.dropAll 1)+ , benchPureSink "dropWhile-true" (Ops.dropWhileTrue 1)+ --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 1)+ , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 1)+ , benchPureSink "deleteBy" (Ops.deleteBy 1)+ , benchPureSink "insertBy" (Ops.insertBy 1)+ ]+ , bgroup "filteringX4"+ [ benchPureSink "filter-even" (Ops.filterEven 4)+ , benchPureSink "filter-all-out" (Ops.filterAllOut 4)+ , benchPureSink "filter-all-in" (Ops.filterAllIn 4)+ , benchPureSink "take-all" (Ops.takeAll 4)+ , benchPureSink "takeWhile-true" (Ops.takeWhileTrue 4)+ --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 4)+ , benchPureSink "drop-one" (Ops.dropOne 4)+ , benchPureSink "drop-all" (Ops.dropAll 4)+ , benchPureSink "dropWhile-true" (Ops.dropWhileTrue 4)+ --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 4)+ , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 4)+ , benchPureSink "deleteBy" (Ops.deleteBy 4)+ , benchPureSink "insertBy" (Ops.insertBy 4)+ ]+ , bgroup "multi-stream"+ [ benchPureSink "eqBy" Ops.eqBy+ , benchPureSink "cmpBy" Ops.cmpBy+ , benchPureSink "zip" Ops.zip+ , benchPureSink "zipM" Ops.zipM+ , benchPureSink "mergeBy" Ops.mergeBy+ , benchPureSink "isPrefixOf" Ops.isPrefixOf+ , benchPureSink "isSubsequenceOf" Ops.isSubsequenceOf+ , benchPureSink "stripPrefix" Ops.stripPrefix+ , benchPureSrc serially "concatMap" Ops.concatMap+ ]+ -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl+ -- library. If scan/fold followed by a map is efficient enough we may not+ -- need monolithic implementations of these.+ , bgroup "mixed"+ [ benchPureSink "scanl-map" (Ops.scanMap 1)+ , benchPureSink "foldl-map" Ops.foldl'ReduceMap+ , benchPureSink "sum-product-fold" Ops.sumProductFold+ , benchPureSink "sum-product-scan" Ops.sumProductScan+ ]+ , bgroup "mixedX4"+ [ benchPureSink "scan-map" (Ops.scanMap 4)+ , benchPureSink "drop-map" (Ops.dropMap 4)+ , benchPureSink "drop-scan" (Ops.dropScan 4)+ , benchPureSink "take-drop" (Ops.takeDrop 4)+ , benchPureSink "take-scan" (Ops.takeScan 4)+ , benchPureSink "take-map" (Ops.takeMap 4)+ , benchPureSink "filter-drop" (Ops.filterDrop 4)+ , benchPureSink "filter-take" (Ops.filterTake 4)+ , benchPureSink "filter-scan" (Ops.filterScan 4)+ , benchPureSink "filter-scanl1" (Ops.filterScanl1 4)+ , benchPureSink "filter-map" (Ops.filterMap 4)+ ]+ , bgroup "iterated"+ [ benchPureSrc serially "mapM" Ops.iterateMapM+ , benchPureSrc serially "scan(1/100)" Ops.iterateScan+ , benchPureSrc serially "scanl1(1/100)" Ops.iterateScanl1+ , benchPureSrc serially "filterEven" Ops.iterateFilterEven+ , benchPureSrc serially "takeAll" Ops.iterateTakeAll+ , benchPureSrc serially "dropOne" Ops.iterateDropOne+ , benchPureSrc serially "dropWhileFalse" Ops.iterateDropWhileFalse+ , benchPureSrc serially "dropWhileTrue" Ops.iterateDropWhileTrue+ ]+ -}+ ]+ ]
+ benchmark/Streamly/Benchmark/Memory/ArrayOps.hs view
@@ -0,0 +1,531 @@+-- |+-- Module : ArrayOps+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : MIT+-- Maintainer : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Streamly.Benchmark.Memory.ArrayOps where++-- import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO)+-- import Data.Maybe (fromJust)+import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined)+import qualified Prelude as P+#ifdef DEVBUILD+import qualified Data.Foldable as F+#endif+import qualified GHC.Exts as GHC+-- import Control.DeepSeq (NFData)+-- import GHC.Generics (Generic)++import qualified Streamly as S hiding (foldMapWith, runStream)+import qualified Streamly.Memory.Array as A+import qualified Streamly.Prelude as S++value, maxValue :: Int+#ifdef LINEAR_ASYNC+value = 10000+#else+value = 100000+#endif+maxValue = value + 1++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++type Stream = A.Array++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: MonadIO m => Int -> m (Stream Int)+sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n+ where+ step cnt =+ if cnt > n + value+ then Nothing+ else (Just (cnt, cnt + 1))++{-# INLINE sourceIntFromTo #-}+sourceIntFromTo :: MonadIO m => Int -> m (Stream Int)+sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value)++{-# INLINE sourceIntFromToFromStream #-}+sourceIntFromToFromStream :: MonadIO m => Int -> m (Stream Int)+sourceIntFromToFromStream n = S.fold A.write $ S.enumerateFromTo n (n + value)++sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int)+sourceIntFromToFromList n = P.return $ A.fromList $ [n..n + value]++{-# INLINE sourceFromList #-}+sourceFromList :: MonadIO m => Int -> m (Stream Int)+sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value]++{-# INLINE sourceIsList #-}+sourceIsList :: Int -> Stream Int+sourceIsList n = GHC.fromList [n..n+value]++{-# INLINE sourceIsString #-}+sourceIsString :: Int -> Stream P.Char+sourceIsString n = GHC.fromString (P.replicate (n + value) 'a')++{-+-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.runStream++{-# INLINE toList #-}+toList :: Monad m => Stream m Int -> m [Int]++{-# INLINE head #-}+{-# INLINE last #-}+{-# INLINE maximum #-}+{-# INLINE minimum #-}+{-# INLINE find #-}+{-# INLINE findIndex #-}+{-# INLINE elemIndex #-}+{-# INLINE foldl1'Reduce #-}+head, last, minimum, maximum, find, findIndex, elemIndex, foldl1'Reduce+ :: Monad m => Stream m Int -> m (Maybe Int)++{-# INLINE minimumBy #-}+{-# INLINE maximumBy #-}+minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int)++{-# INLINE foldl'Reduce #-}+{-# INLINE foldl'ReduceMap #-}+{-# INLINE foldlM'Reduce #-}+{-# INLINE foldrMReduce #-}+{-# INLINE length #-}+{-# INLINE sum #-}+{-# INLINE product #-}+foldl'Reduce, foldl'ReduceMap, foldlM'Reduce, foldrMReduce, length, sum, product+ :: Monad m+ => Stream m Int -> m Int++{-# INLINE foldl'Build #-}+{-# INLINE foldlM'Build #-}+{-# INLINE foldrMBuild #-}+foldrMBuild, foldl'Build, foldlM'Build+ :: Monad m+ => Stream m Int -> m [Int]++{-# INLINE all #-}+{-# INLINE any #-}+{-# INLINE and #-}+{-# INLINE or #-}+{-# INLINE null #-}+{-# INLINE elem #-}+{-# INLINE notElem #-}+null, elem, notElem, all, any, and, or :: Monad m => Stream m Int -> m Bool++{-# INLINE toNull #-}+toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()+toNull t = runStream . t++{-# INLINE uncons #-}+uncons :: Monad m => Stream m Int -> m ()+uncons s = do+ r <- S.uncons s+ case r of+ Nothing -> return ()+ Just (_, t) -> uncons t++{-# INLINE init #-}+init :: Monad m => Stream m a -> m ()+init s = S.init s >>= Prelude.mapM_ S.runStream++{-# INLINE tail #-}+tail :: Monad m => Stream m a -> m ()+tail s = S.tail s >>= Prelude.mapM_ tail++{-# INLINE nullHeadTail #-}+nullHeadTail :: Monad m => Stream m Int -> m ()+nullHeadTail s = do+ r <- S.null s+ when (not r) $ do+ _ <- S.head s+ S.tail s >>= Prelude.mapM_ nullHeadTail++{-# INLINE mapM_ #-}+mapM_ :: Monad m => Stream m Int -> m ()+mapM_ = S.mapM_ (\_ -> return ())++toList = S.toList++{-# INLINE toRevList #-}+toRevList :: Monad m => Stream m Int -> m [Int]+toRevList = S.toRevList++foldrMBuild = S.foldrM (\x xs -> xs >>= return . (x :)) (return [])+foldl'Build = S.foldl' (flip (:)) []+foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []++foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0)+foldl'Reduce = S.foldl' (+) 0+foldl'ReduceMap = P.fmap (+1) . S.foldl' (+) 0+foldl1'Reduce = S.foldl1' (+)+foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0++last = S.last+null = S.null+head = S.head+elem = S.elem maxValue+notElem = S.notElem maxValue+length = S.length+all = S.all (<= maxValue)+any = S.any (> maxValue)+and = S.and . S.map (<= maxValue)+or = S.or . S.map (> maxValue)+find = S.find (== maxValue)+findIndex = S.findIndex (== maxValue)+elemIndex = S.elemIndex maxValue+maximum = S.maximum+minimum = S.minimum+sum = S.sum+product = S.product+minimumBy = S.minimumBy compare+maximumBy = S.maximumBy compare+-}++-------------------------------------------------------------------------------+-- Transformation+-------------------------------------------------------------------------------++{-+{-# INLINE transform #-}+transform :: Stream a -> Stream a+transform = P.id+-}++{-# INLINE composeN #-}+composeN :: P.Monad m+ => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int)+composeN n f x =+ case n of+ 1 -> f x+ 2 -> f x P.>>= f+ 3 -> f x P.>>= f P.>>= f+ 4 -> f x P.>>= f P.>>= f P.>>= f+ _ -> undefined++{-# INLINE scanl' #-}+{-# INLINE scanl1' #-}+{-# INLINE map #-}+{-+{-# INLINE fmap #-}+{-# INLINE mapMaybe #-}+{-# INLINE filterEven #-}+{-# INLINE filterAllOut #-}+{-# INLINE filterAllIn #-}+{-# INLINE takeOne #-}+{-# INLINE takeAll #-}+{-# INLINE takeWhileTrue #-}+{-# INLINE takeWhileMTrue #-}+{-# INLINE dropOne #-}+{-# INLINE dropAll #-}+{-# INLINE dropWhileTrue #-}+{-# INLINE dropWhileMTrue #-}+{-# INLINE dropWhileFalse #-}+{-# INLINE findIndices #-}+{-# INLINE elemIndices #-}+{-# INLINE insertBy #-}+{-# INLINE deleteBy #-}+{-# INLINE reverse #-}+{-# INLINE foldrS #-}+{-# INLINE foldrSMap #-}+{-# INLINE foldrT #-}+{-# INLINE foldrTMap #-}+ -}+scanl' , scanl1', map{-, fmap, mapMaybe, filterEven, filterAllOut,+ filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,+ dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse,+ findIndices, elemIndices, insertBy, deleteBy, reverse,+ foldrS, foldrSMap, foldrT, foldrTMap -}+ :: MonadIO m => Int -> Stream Int -> m (Stream Int)++{-+{-# INLINE mapMaybeM #-}+mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m ()++{-# INLINE mapM #-}+{-# INLINE map' #-}+{-# INLINE fmap' #-}+mapM, map' :: (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()++fmap' :: (S.IsStream t, S.MonadAsync m, P.Functor (t m))+ => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()++{-# INLINE sequence #-}+sequence :: (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int) -> t m (m Int) -> m ()+ -}++{-# INLINE onArray #-}+onArray+ :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int)+ -> Stream Int+ -> m (Stream Int)+onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr)++scanl' n = composeN n $ onArray $ S.scanl' (+) 0+scanl1' n = composeN n $ onArray $ S.scanl1' (+)+map n = composeN n $ onArray $ S.map (+1)+-- map n = composeN n $ A.map (+1)+{-+fmap n = composeN n $ Prelude.fmap (+1)+fmap' t n = composeN' n $ t . Prelude.fmap (+1)+map' t n = composeN' n $ t . S.map (+1)+mapM t n = composeN' n $ t . S.mapM return+mapMaybe n = composeN n $ S.mapMaybe+ (\x -> if Prelude.odd x then Nothing else Just x)+mapMaybeM n = composeN n $ S.mapMaybeM+ (\x -> if Prelude.odd x then return Nothing else return $ Just x)+sequence t = transform . t . S.sequence+filterEven n = composeN n $ S.filter even+filterAllOut n = composeN n $ S.filter (> maxValue)+filterAllIn n = composeN n $ S.filter (<= maxValue)+takeOne n = composeN n $ S.take 1+takeAll n = composeN n $ S.take maxValue+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)+takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))+dropOne n = composeN n $ S.drop 1+dropAll n = composeN n $ S.drop maxValue+dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)+dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))+dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)+findIndices n = composeN n $ S.findIndices (== maxValue)+elemIndices n = composeN n $ S.elemIndices maxValue+insertBy n = composeN n $ S.insertBy compare maxValue+deleteBy n = composeN n $ S.deleteBy (>=) maxValue+reverse n = composeN n $ S.reverse+foldrS n = composeN n $ S.foldrS S.cons S.nil+foldrSMap n = composeN n $ S.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil+foldrT n = composeN n $ S.foldrT S.cons S.nil+foldrTMap n = composeN n $ S.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil++-------------------------------------------------------------------------------+-- Iteration+-------------------------------------------------------------------------------++iterStreamLen, maxIters :: Int+iterStreamLen = 10+maxIters = 10000++{-# INLINE iterateSource #-}+iterateSource+ :: S.MonadAsync m+ => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)+ where+ f (0 :: Int) m = g m+ f x m = g (f (x P.- 1) m)++{-# INLINE iterateMapM #-}+{-# INLINE iterateScan #-}+{-# INLINE iterateScanl1 #-}+{-# INLINE iterateFilterEven #-}+{-# INLINE iterateTakeAll #-}+{-# INLINE iterateDropOne #-}+{-# INLINE iterateDropWhileFalse #-}+{-# INLINE iterateDropWhileTrue #-}+iterateMapM, iterateScan, iterateScanl1, iterateFilterEven, iterateTakeAll,+ iterateDropOne, iterateDropWhileFalse, iterateDropWhileTrue+ :: S.MonadAsync m+ => Int -> Stream m Int++-- this is quadratic+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)+-- so is this+iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10)++iterateMapM = iterateSource (S.mapM return) maxIters+iterateFilterEven = iterateSource (S.filter even) maxIters+iterateTakeAll = iterateSource (S.take maxValue) maxIters+iterateDropOne = iterateSource (S.drop 1) maxIters+iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue)) maxIters+iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters++-------------------------------------------------------------------------------+-- Zipping and concat+-------------------------------------------------------------------------------++{-# INLINE zip #-}+{-# INLINE zipM #-}+{-# INLINE mergeBy #-}+zip, zipM, mergeBy :: Monad m => Stream m Int -> m ()++zip src = do+ r <- S.tail src+ let src1 = fromJust r+ transform (S.zipWith (,) src src1)+zipM src = do+ r <- S.tail src+ let src1 = fromJust r+ transform (S.zipWithM (curry return) src src1)++mergeBy src = do+ r <- S.tail src+ let src1 = fromJust r+ transform (S.mergeBy P.compare src src1)++{-# INLINE isPrefixOf #-}+{-# INLINE isSubsequenceOf #-}+isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool++isPrefixOf src = S.isPrefixOf src src+isSubsequenceOf src = S.isSubsequenceOf src src++{-# INLINE stripPrefix #-}+stripPrefix :: Monad m => Stream m Int -> m ()+stripPrefix src = do+ _ <- S.stripPrefix src src+ return ()++{-# INLINE zipAsync #-}+{-# INLINE zipAsyncM #-}+{-# INLINE zipAsyncAp #-}+zipAsync, zipAsyncAp, zipAsyncM :: S.MonadAsync m => Stream m Int -> m ()++zipAsync src = do+ r <- S.tail src+ let src1 = fromJust r+ transform (S.zipAsyncWith (,) src src1)++zipAsyncM src = do+ r <- S.tail src+ let src1 = fromJust r+ transform (S.zipAsyncWithM (curry return) src src1)++zipAsyncAp src = do+ r <- S.tail src+ let src1 = fromJust r+ transform (S.zipAsyncly $ (,) <$> S.serially src+ <*> S.serially src1)++{-# INLINE eqBy #-}+eqBy :: (Monad m, P.Eq a) => Stream m a -> m P.Bool+eqBy src = S.eqBy (==) src src++{-# INLINE cmpBy #-}+cmpBy :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering+cmpBy src = S.cmpBy P.compare src src++concatStreamLen, maxNested :: Int+concatStreamLen = 1+maxNested = 100000++{-# INLINE concatMap #-}+concatMap :: S.MonadAsync m => Int -> Stream m Int+concatMap n = S.concatMap (\_ -> sourceUnfoldrMN maxNested n)+ (sourceUnfoldrMN concatStreamLen n)++-------------------------------------------------------------------------------+-- Mixed Composition+-------------------------------------------------------------------------------++{-# INLINE scanMap #-}+{-# INLINE dropMap #-}+{-# INLINE dropScan #-}+{-# INLINE takeDrop #-}+{-# INLINE takeScan #-}+{-# INLINE takeMap #-}+{-# INLINE filterDrop #-}+{-# INLINE filterTake #-}+{-# INLINE filterScan #-}+{-# INLINE filterScanl1 #-}+{-# INLINE filterMap #-}+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,+ filterTake, filterScan, filterScanl1, filterMap+ :: Monad m => Int -> Stream m Int -> m ()++scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1+takeDrop n = composeN n $ S.drop 1 . S.take maxValue+takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue+takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)+filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)+filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++data Pair a b = Pair !a !b deriving (Generic, NFData)++{-# INLINE sumProductFold #-}+sumProductFold :: Monad m => Stream m Int -> m (Int, Int)+sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1)++{-# INLINE sumProductScan #-}+sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)+sumProductScan = S.foldl' (\(Pair _ p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1)+ . S.scanl' (\(s,_) x -> (s + x,x)) (0,0)++-------------------------------------------------------------------------------+-- Pure stream operations+-------------------------------------------------------------------------------++-}+{-# INLINE eqInstance #-}+eqInstance :: Stream Int -> Bool+eqInstance src = src == src++{-# INLINE eqInstanceNotEq #-}+eqInstanceNotEq :: Stream Int -> Bool+eqInstanceNotEq src = src P./= src++{-# INLINE ordInstance #-}+ordInstance :: Stream Int -> Bool+ordInstance src = src P.< src++{-# INLINE ordInstanceMin #-}+ordInstanceMin :: Stream Int -> Stream Int+ordInstanceMin src = P.min src src++{-# INLINE showInstance #-}+showInstance :: Stream Int -> P.String+showInstance src = P.show src++{-# INLINE readInstance #-}+readInstance :: P.String -> Stream Int+readInstance str =+ let r = P.reads str+ in case r of+ [(x,"")] -> x+ _ -> P.error "readInstance: no parse"++{-# INLINE pureFoldl' #-}+pureFoldl' :: MonadIO m => Stream Int -> m Int+pureFoldl' = S.foldl' (+) 0 . S.unfold A.read++#ifdef DEVBUILD+{-# INLINE foldableFoldl' #-}+foldableFoldl' :: Stream Int -> Int+foldableFoldl' = F.foldl' (+) 0++{-# INLINE foldableSum #-}+foldableSum :: Stream Int -> Int+foldableSum = P.sum+#endif++{-+{-# INLINE traversableMapM #-}+traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)+traversableMapM = P.mapM return+-}
− benchmark/Streamly/Benchmark/Prelude.hs
@@ -1,1202 +0,0 @@--- |--- Module : Streamly.Benchmark.Prelude--- Copyright : (c) 2018 Harendra Kumar------ License : MIT--- Maintainer : streamly@composewell.com--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes #-}--#ifdef __HADDOCK_VERSION__-#undef INSPECTION-#endif--#ifdef INSPECTION-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-#endif--module Streamly.Benchmark.Prelude where--import Control.DeepSeq (NFData)-import Control.Monad (when)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.State.Strict (StateT, get, put)-import Data.Functor.Identity (Identity, runIdentity)-import Data.IORef (newIORef, modifyIORef')-import GHC.Generics (Generic)-import Prelude- (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), (==), (>=),- subtract, undefined, Maybe(..), odd, Bool, not, (>>=), mapM_, curry,- maxBound, div, IO, compare, Double, fromIntegral, Integer, (<$>),- (<*>), flip)-import qualified Prelude as P-import qualified Data.Foldable as F-import qualified GHC.Exts as GHC--#ifdef INSPECTION-import Test.Inspection--import qualified Streamly.Internal.Data.Stream.StreamD as D-#endif--import qualified Streamly as S hiding (runStream)-import qualified Streamly.Prelude as S-import qualified Streamly.Internal.Prelude as Internal-import qualified Streamly.Internal.Data.Fold as FL-import qualified Streamly.Internal.Data.Unfold as UF-import qualified Streamly.Internal.Data.Pipe as Pipe-import qualified Streamly.Internal.Data.Stream.Parallel as Par-import Streamly.Internal.Data.Time.Units--type Stream m a = S.SerialT m a------------------------------------------------------------------------------------ Stream generation------------------------------------------------------------------------------------ enumerate--{-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceIntFromTo value n = S.enumerateFromTo n (n + value)--{-# INLINE sourceIntFromThenTo #-}-sourceIntFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceIntFromThenTo value n = S.enumerateFromThenTo n (n + 1) (n + value)--{-# INLINE sourceFracFromTo #-}-sourceFracFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double-sourceFracFromTo value n =- S.enumerateFromTo (fromIntegral n) (fromIntegral (n + value))--{-# INLINE sourceFracFromThenTo #-}-sourceFracFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double-sourceFracFromThenTo value n = S.enumerateFromThenTo (fromIntegral n)- (fromIntegral n + 1.0001) (fromIntegral (n + value))--{-# INLINE sourceIntegerFromStep #-}-sourceIntegerFromStep :: (Monad m, S.IsStream t) => Int -> Int -> t m Integer-sourceIntegerFromStep value n =- S.take value $ S.enumerateFromThen (fromIntegral n) (fromIntegral n + 1)---- unfoldr--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceUnfoldr value n = S.unfoldr step n- where- step cnt =- if cnt > n + value- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrN #-}-sourceUnfoldrN :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceUnfoldrN upto start = S.unfoldr step start- where- step cnt =- if cnt > start + upto- then Nothing- else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceUnfoldrM value n = S.unfoldrM step n- where- step cnt =- if cnt > n + value- then return Nothing- else return (Just (cnt, cnt + 1))--{-# INLINE source #-}-source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-source = sourceUnfoldrM--{-# INLINE sourceUnfoldrMN #-}-sourceUnfoldrMN :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceUnfoldrMN upto start = S.unfoldrM step start- where- step cnt =- if cnt > start + upto- then return Nothing- else return (Just (cnt, cnt + 1))--{-# INLINE sourceUnfoldrMAction #-}-sourceUnfoldrMAction :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (m Int)-sourceUnfoldrMAction value n = S.serially $ S.unfoldrM step n- where- step cnt =- if cnt > n + value- then return Nothing- else return (Just (return cnt, cnt + 1))--{-# INLINE sourceUnfoldrAction #-}-sourceUnfoldrAction :: (S.IsStream t, Monad m, Monad m1)- => Int -> Int -> t m (m1 Int)-sourceUnfoldrAction value n = S.serially $ S.unfoldr step n- where- step cnt =- if cnt > n + value- then Nothing- else (Just (return cnt, cnt + 1))---- fromIndices--{-# INLINE sourceFromIndices #-}-sourceFromIndices :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceFromIndices value n = S.take value $ S.fromIndices (+ n)--{-# INLINE sourceFromIndicesM #-}-sourceFromIndicesM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-sourceFromIndicesM value n = S.take value $ S.fromIndicesM (Prelude.fmap return (+ n))---- fromList--{-# INLINE sourceFromList #-}-sourceFromList :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceFromList value n = S.fromList [n..n+value]--{-# INLINE sourceFromListM #-}-sourceFromListM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-sourceFromListM value n = S.fromListM (Prelude.fmap return [n..n+value])--{-# INLINE sourceIsList #-}-sourceIsList :: Int -> Int -> S.SerialT Identity Int-sourceIsList value n = GHC.fromList [n..n+value]--{-# INLINE sourceIsString #-}-sourceIsString :: Int -> Int -> S.SerialT Identity P.Char-sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a')---- fromFoldable--{-# INLINE sourceFromFoldable #-}-sourceFromFoldable :: S.IsStream t => Int -> Int -> t m Int-sourceFromFoldable value n = S.fromFoldable [n..n+value]--{-# INLINE sourceFromFoldableM #-}-sourceFromFoldableM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceFromFoldableM value n = S.fromFoldableM (Prelude.fmap return [n..n+value])--{-# INLINE currentTime #-}-currentTime :: (S.IsStream t, S.MonadAsync m)- => Int -> Double -> Int -> t m AbsTime-currentTime value g _ = S.take value $ Internal.currentTime g------------------------------------------------------------------------------------ Elimination----------------------------------------------------------------------------------{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]--{-# INLINE head #-}-{-# INLINE last #-}-{-# INLINE maximum #-}-{-# INLINE minimum #-}-{-# INLINE find #-}-{-# INLINE findIndex #-}-{-# INLINE elemIndex #-}-{-# INLINE foldl1'Reduce #-}-head, last, minimum, maximum, foldl1'Reduce- :: Monad m => Stream m Int -> m (Maybe Int)--find, findIndex, elemIndex- :: Monad m => Int -> Stream m Int -> m (Maybe Int)--{-# INLINE minimumBy #-}-{-# INLINE maximumBy #-}-minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int)--{-# INLINE foldl'Reduce #-}-{-# INLINE foldl'ReduceMap #-}-{-# INLINE foldlM'Reduce #-}-{-# INLINE foldrMReduce #-}-{-# INLINE length #-}-{-# INLINE sum #-}-{-# INLINE product #-}-foldl'Reduce, foldl'ReduceMap, foldlM'Reduce, foldrMReduce, length, sum, product- :: Monad m- => Stream m Int -> m Int--{-# INLINE foldl'Build #-}-{-# INLINE foldlM'Build #-}-{-# INLINE foldrMBuild #-}-foldrMBuild, foldl'Build, foldlM'Build- :: Monad m- => Stream m Int -> m [Int]--{-# INLINE all #-}-{-# INLINE any #-}-{-# INLINE and #-}-{-# INLINE or #-}-{-# INLINE null #-}-{-# INLINE elem #-}-{-# INLINE notElem #-}-null :: Monad m => Stream m Int -> m Bool--elem, notElem, all, any, and, or :: Monad m => Int -> Stream m Int -> m Bool--{-# INLINE toNull #-}-toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()-toNull t = runStream . t--{-# INLINE uncons #-}-uncons :: Monad m => Stream m Int -> m ()-uncons s = do- r <- S.uncons s- case r of- Nothing -> return ()- Just (_, t) -> uncons t--{-# INLINE init #-}-init :: Monad m => Stream m a -> m ()-init s = S.init s >>= Prelude.mapM_ S.drain--{-# INLINE tail #-}-tail :: Monad m => Stream m a -> m ()-tail s = S.tail s >>= Prelude.mapM_ tail--{-# INLINE nullHeadTail #-}-nullHeadTail :: Monad m => Stream m Int -> m ()-nullHeadTail s = do- r <- S.null s- when (not r) $ do- _ <- S.head s- S.tail s >>= Prelude.mapM_ nullHeadTail--{-# INLINE mapM_ #-}-mapM_ :: Monad m => Stream m Int -> m ()-mapM_ = S.mapM_ (\_ -> return ())--toList = S.toList--{-# INLINE toListRev #-}-toListRev :: Monad m => Stream m Int -> m [Int]-toListRev = Internal.toListRev--{-# INLINE foldrMElem #-}-foldrMElem :: Monad m => Int -> Stream m Int -> m Bool-foldrMElem e m = S.foldrM (\x xs -> if x == e then return P.True else xs)- (return P.False) m--{-# INLINE foldrMToStream #-}-foldrMToStream :: Monad m => Stream m Int -> m (Stream Identity Int)-foldrMToStream = S.foldr S.cons S.nil--foldrMBuild = S.foldrM (\x xs -> xs >>= return . (x :)) (return [])-foldl'Build = S.foldl' (flip (:)) []-foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []--foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0)-foldl'Reduce = S.foldl' (+) 0-foldl'ReduceMap = P.fmap (+1) . S.foldl' (+) 0-foldl1'Reduce = S.foldl1' (+)-foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0--last = S.last-null = S.null-head = S.head-elem value = S.elem (value + 1)-notElem value = S.notElem (value + 1)-length = S.length-all value = S.all (<= (value + 1))-any value = S.any (> (value + 1))-and value = S.and . S.map (<= (value + 1))-or value = S.or . S.map (> (value + 1))-find value = S.find (== (value + 1))-findIndex value = S.findIndex (== (value + 1))-elemIndex value = S.elemIndex (value + 1)-maximum = S.maximum-minimum = S.minimum-sum = S.sum-product = S.product-minimumBy = S.minimumBy compare-maximumBy = S.maximumBy compare------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{-# INLINE transform #-}-transform :: Monad m => Stream m a -> m ()-transform = runStream--{-# INLINE composeN #-}-composeN- :: MonadIO m- => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()-composeN n f =- case n of- 1 -> transform . f- 2 -> transform . f . f- 3 -> transform . f . f . f- 4 -> transform . f . f . f . f- _ -> undefined---- polymorphic stream version of composeN-{-# INLINE composeN' #-}-composeN'- :: (S.IsStream t, Monad m)- => Int -> (t m Int -> Stream m Int) -> t m Int -> m ()-composeN' n f =- case n of- 1 -> transform . f- 2 -> transform . f . S.adapt . f- 3 -> transform . f . S.adapt . f . S.adapt . f- 4 -> transform . f . S.adapt . f . S.adapt . f . S.adapt . f- _ -> undefined--{-# INLINE scan #-}-{-# INLINE scanl1' #-}-{-# INLINE map #-}-{-# INLINE fmap #-}-{-# INLINE mapMaybe #-}-{-# INLINE filterEven #-}-{-# INLINE filterAllOut #-}-{-# INLINE filterAllIn #-}-{-# INLINE takeOne #-}-{-# INLINE takeAll #-}-{-# INLINE takeWhileTrue #-}-{-# INLINE takeWhileMTrue #-}-{-# INLINE dropOne #-}-{-# INLINE dropAll #-}-{-# INLINE dropWhileTrue #-}-{-# INLINE dropWhileMTrue #-}-{-# INLINE dropWhileFalse #-}-{-# INLINE findIndices #-}-{-# INLINE elemIndices #-}-{-# INLINE insertBy #-}-{-# INLINE deleteBy #-}-{-# INLINE reverse #-}-{-# INLINE reverse' #-}-{-# INLINE foldrS #-}-{-# INLINE foldrSMap #-}-{-# INLINE foldrT #-}-{-# INLINE foldrTMap #-}-scan, scanl1', map, fmap, mapMaybe, filterEven,- takeOne, dropOne,- reverse, reverse',- foldrS, foldrSMap, foldrT, foldrTMap- :: MonadIO m- => Int -> Stream m Int -> m ()--filterAllOut,- filterAllIn, takeAll, takeWhileTrue, takeWhileMTrue,- dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse,- findIndices, elemIndices, insertBy, deleteBy- :: MonadIO m- => Int -> Int -> Stream m Int -> m ()--{-# INLINE mapMaybeM #-}-{-# INLINE intersperse #-}-mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m ()-intersperse :: S.MonadAsync m => Int -> Int -> Stream m Int -> m ()--{-# INLINE mapM #-}-{-# INLINE map' #-}-{-# INLINE fmap' #-}-mapM, map' :: (S.IsStream t, S.MonadAsync m)- => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()--fmap' :: (S.IsStream t, S.MonadAsync m, P.Functor (t m))- => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()--{-# INLINE sequence #-}-sequence :: (S.IsStream t, S.MonadAsync m)- => (t m Int -> S.SerialT m Int) -> t m (m Int) -> m ()--scan n = composeN n $ S.scanl' (+) 0-scanl1' n = composeN n $ S.scanl1' (+)-fmap n = composeN n $ Prelude.fmap (+1)-fmap' t n = composeN' n $ t . Prelude.fmap (+1)-map n = composeN n $ S.map (+1)-map' t n = composeN' n $ t . S.map (+1)-mapM t n = composeN' n $ t . S.mapM return--{-# INLINE tap #-}-tap :: MonadIO m => Int -> Stream m Int -> m ()-tap n = composeN n $ S.tap FL.sum--{-# INLINE tapRate #-}-tapRate :: Int -> Stream IO Int -> IO ()-tapRate n str = do- cref <- newIORef 0- composeN n (Internal.tapRate 1 (\c -> modifyIORef' cref (c +))) str--{-# INLINE pollCounts #-}-pollCounts :: Int -> Stream IO Int -> IO ()-pollCounts n str = do- composeN n (Internal.pollCounts (P.const P.True) f FL.drain) str- where f = Internal.rollingMap (P.-) . Internal.delayPost 1--{-# INLINE tapAsyncS #-}-tapAsyncS :: S.MonadAsync m => Int -> Stream m Int -> m ()-tapAsyncS n = composeN n $ Par.tapAsync S.sum--{-# INLINE tapAsync #-}-tapAsync :: S.MonadAsync m => Int -> Stream m Int -> m ()-tapAsync n = composeN n $ Internal.tapAsync FL.sum--mapMaybe n = composeN n $ S.mapMaybe- (\x -> if Prelude.odd x then Nothing else Just x)-mapMaybeM n = composeN n $ S.mapMaybeM- (\x -> if Prelude.odd x then return Nothing else return $ Just x)-sequence t = transform . t . S.sequence-filterEven n = composeN n $ S.filter even-filterAllOut value n = composeN n $ S.filter (> (value + 1))-filterAllIn value n = composeN n $ S.filter (<= (value + 1))-takeOne n = composeN n $ S.take 1-takeAll value n = composeN n $ S.take (value + 1)-takeWhileTrue value n = composeN n $ S.takeWhile (<= (value + 1))-takeWhileMTrue value n = composeN n $ S.takeWhileM (return . (<= (value + 1)))-dropOne n = composeN n $ S.drop 1-dropAll value n = composeN n $ S.drop (value + 1)-dropWhileTrue value n = composeN n $ S.dropWhile (<= (value + 1))-dropWhileMTrue value n = composeN n $ S.dropWhileM (return . (<= (value + 1)))-dropWhileFalse value n = composeN n $ S.dropWhile (> (value + 1))-findIndices value n = composeN n $ S.findIndices (== (value + 1))-elemIndices value n = composeN n $ S.elemIndices (value + 1)-intersperse value n = composeN n $ S.intersperse (value + 1)-insertBy value n = composeN n $ S.insertBy compare (value + 1)-deleteBy value n = composeN n $ S.deleteBy (>=) (value + 1)-reverse n = composeN n $ S.reverse-reverse' n = composeN n $ Internal.reverse'-foldrS n = composeN n $ Internal.foldrS S.cons S.nil-foldrSMap n = composeN n $ Internal.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil-foldrT n = composeN n $ Internal.foldrT S.cons S.nil-foldrTMap n = composeN n $ Internal.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil--{-# INLINE takeByTime #-}-takeByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO ()-takeByTime i n = composeN n (Internal.takeByTime i)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'takeByTime--- inspect $ 'takeByTime `hasNoType` ''D.Step-#endif--{-# INLINE dropByTime #-}-dropByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO ()-dropByTime i n = composeN n (Internal.dropByTime i)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'dropByTime--- inspect $ 'dropByTime `hasNoType` ''D.Step-#endif------------------------------------------------------------------------------------ Pipes----------------------------------------------------------------------------------{-# INLINE transformMapM #-}-{-# INLINE transformComposeMapM #-}-{-# INLINE transformTeeMapM #-}-{-# INLINE transformZipMapM #-}--transformMapM, transformComposeMapM, transformTeeMapM,- transformZipMapM :: (S.IsStream t, S.MonadAsync m)- => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()--transformMapM t n = composeN' n $ t . Internal.transform (Pipe.mapM return)-transformComposeMapM t n = composeN' n $ t . Internal.transform- (Pipe.mapM (\x -> return (x + 1))- `Pipe.compose` Pipe.mapM (\x -> return (x + 2)))-transformTeeMapM t n = composeN' n $ t . Internal.transform- (Pipe.mapM (\x -> return (x + 1))- `Pipe.tee` Pipe.mapM (\x -> return (x + 2)))-transformZipMapM t n = composeN' n $ t . Internal.transform- (Pipe.zipWith (+) (Pipe.mapM (\x -> return (x + 1)))- (Pipe.mapM (\x -> return (x + 2))))------------------------------------------------------------------------------------ Mixed Transformation----------------------------------------------------------------------------------{-# INLINE scanMap #-}-{-# INLINE dropMap #-}-{-# INLINE dropScan #-}-{-# INLINE takeDrop #-}-{-# INLINE takeScan #-}-{-# INLINE takeMap #-}-{-# INLINE filterDrop #-}-{-# INLINE filterTake #-}-{-# INLINE filterScan #-}-{-# INLINE filterScanl1 #-}-{-# INLINE filterMap #-}-scanMap, dropMap, dropScan,- filterScan, filterScanl1- :: MonadIO m => Int -> Stream m Int -> m ()--takeDrop, takeScan, takeMap, filterDrop,- filterTake, filterMap- :: MonadIO m => Int -> Int -> Stream m Int -> m ()--scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop value n = composeN n $ S.drop 1 . S.take (value + 1)-takeScan value n = composeN n $ S.scanl' (+) 0 . S.take (value + 1)-takeMap value n = composeN n $ S.map (subtract 1) . S.take (value + 1)-filterDrop value n = composeN n $ S.drop 1 . S.filter (<= (value + 1))-filterTake value n = composeN n $ S.take (value + 1) . S.filter (<= (value + 1))-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)-filterMap value n = composeN n $ S.map (subtract 1) . S.filter (<= (value + 1))------------------------------------------------------------------------------------ Scan and fold----------------------------------------------------------------------------------data Pair a b = Pair !a !b deriving (Generic, NFData)--{-# INLINE sumProductFold #-}-sumProductFold :: Monad m => Stream m Int -> m (Int, Int)-sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1)--{-# INLINE sumProductScan #-}-sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)-sumProductScan = S.foldl' (\(Pair _ p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1)- . S.scanl' (\(s,_) x -> (s + x,x)) (0,0)------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource- :: S.MonadAsync m- => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)- where- f (0 :: Int) m = g m- f x m = g (f (x P.- 1) m)--{-# INLINE iterateMapM #-}-{-# INLINE iterateScan #-}-{-# INLINE iterateScanl1 #-}-{-# INLINE iterateFilterEven #-}-{-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateScanl1, iterateFilterEven,- iterateDropOne- :: S.MonadAsync m- => Int -> Stream m Int--iterateTakeAll,- iterateDropWhileFalse, iterateDropWhileTrue- :: S.MonadAsync m- => Int -> Int -> Stream m Int---- this is quadratic-iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)--- so is this-iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10)--iterateMapM = iterateSource (S.mapM return) maxIters-iterateFilterEven = iterateSource (S.filter even) maxIters-iterateTakeAll value = iterateSource (S.take (value + 1)) maxIters-iterateDropOne = iterateSource (S.drop 1) maxIters-iterateDropWhileFalse value = iterateSource (S.dropWhile (> (value + 1))) maxIters-iterateDropWhileTrue value = iterateSource (S.dropWhile (<= (value + 1))) maxIters------------------------------------------------------------------------------------ Combining streams-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Appending----------------------------------------------------------------------------------{-# INLINE serial2 #-}-serial2 :: Int -> Int -> IO ()-serial2 count n =- S.drain $ S.serial- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--{-# INLINE serial4 #-}-serial4 :: Int -> Int -> IO ()-serial4 count n =- S.drain $ S.serial- ((S.serial (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))))- ((S.serial (sourceUnfoldrMN count (n+2))- (sourceUnfoldrMN count (n + 3))))--{-# INLINE append2 #-}-append2 :: Int -> Int -> IO ()-append2 count n =- S.drain $ Internal.append- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--{-# INLINE append4 #-}-append4 :: Int -> Int -> IO ()-append4 count n =- S.drain $ Internal.append- ((Internal.append (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))))- ((Internal.append (sourceUnfoldrMN count (n+2))- (sourceUnfoldrMN count (n + 3))))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'append2-inspect $ 'append2 `hasNoType` ''D.AppendState-#endif------------------------------------------------------------------------------------ Interleaving----------------------------------------------------------------------------------{-# INLINE wSerial2 #-}-wSerial2 :: Int -> Int -> IO ()-wSerial2 value n = S.drain $ S.wSerial- (sourceUnfoldrMN (value `div` 2) n)- (sourceUnfoldrMN (value `div` 2) (n + 1))--{-# INLINE interleave2 #-}-interleave2 :: Int -> Int -> IO ()-interleave2 value n = S.drain $ Internal.interleave- (sourceUnfoldrMN (value `div` 2) n)- (sourceUnfoldrMN (value `div` 2) (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'interleave2-inspect $ 'interleave2 `hasNoType` ''D.InterleaveState-#endif--{-# INLINE roundRobin2 #-}-roundRobin2 :: Int -> Int -> IO ()-roundRobin2 value n = S.drain $ Internal.roundrobin- (sourceUnfoldrMN (value `div` 2) n)- (sourceUnfoldrMN (value `div` 2) (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'roundRobin2-inspect $ 'roundRobin2 `hasNoType` ''D.InterleaveState-#endif------------------------------------------------------------------------------------ Merging----------------------------------------------------------------------------------{-# INLINE mergeBy #-}-mergeBy :: Int -> Int -> IO ()-mergeBy count n =- S.drain $ S.mergeBy P.compare- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'mergeBy-inspect $ 'mergeBy `hasNoType` ''D.Step-#endif------------------------------------------------------------------------------------ Zipping----------------------------------------------------------------------------------{-# INLINE zip #-}-zip :: Int -> Int -> IO ()-zip count n =- S.drain $ S.zipWith (,)- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'zip-inspect $ 'zip `hasNoType` ''D.Step-#endif--{-# INLINE zipM #-}-zipM :: Int -> Int -> IO ()-zipM count n =- S.drain $ S.zipWithM (curry return)- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'zipM-inspect $ 'zipM `hasNoType` ''D.Step-#endif--{-# INLINE zipAsync #-}-zipAsync :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)-zipAsync count n = do- S.zipAsyncWith (,)- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--{-# INLINE zipAsyncM #-}-zipAsyncM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)-zipAsyncM count n = do- S.zipAsyncWithM (curry return)- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--{-# INLINE zipAsyncAp #-}-zipAsyncAp :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)-zipAsyncAp count n = do- S.zipAsyncly $ (,)- <$> (sourceUnfoldrMN count n)- <*> (sourceUnfoldrMN count (n + 1))--{-# INLINE mergeAsyncByM #-}-mergeAsyncByM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-mergeAsyncByM count n = do- S.mergeAsyncByM (\a b -> return (a `compare` b))- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))--{-# INLINE mergeAsyncBy #-}-mergeAsyncBy :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-mergeAsyncBy count n = do- S.mergeAsyncBy compare- (sourceUnfoldrMN count n)- (sourceUnfoldrMN count (n + 1))------------------------------------------------------------------------------------ Multi-stream folds----------------------------------------------------------------------------------{-# INLINE isPrefixOf #-}-{-# INLINE isSubsequenceOf #-}-isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool--isPrefixOf src = S.isPrefixOf src src-isSubsequenceOf src = S.isSubsequenceOf src src--{-# INLINE stripPrefix #-}-stripPrefix :: Monad m => Stream m Int -> m ()-stripPrefix src = do- _ <- S.stripPrefix src src- return ()--{-# INLINE eqBy' #-}-eqBy' :: (Monad m, P.Eq a) => Stream m a -> m P.Bool-eqBy' src = S.eqBy (==) src src--{-# INLINE eqBy #-}-eqBy :: Int -> Int -> IO Bool-eqBy value n = eqBy' (source value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'eqBy-inspect $ 'eqBy `hasNoType` ''D.Step-#endif---{-# INLINE eqByPure #-}-eqByPure :: Int -> Int -> Identity Bool-eqByPure value n = eqBy' (sourceUnfoldr value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'eqByPure-inspect $ 'eqByPure `hasNoType` ''D.Step-#endif--{-# INLINE cmpBy' #-}-cmpBy' :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering-cmpBy' src = S.cmpBy P.compare src src--{-# INLINE cmpBy #-}-cmpBy :: Int -> Int -> IO P.Ordering-cmpBy value n = cmpBy' (source value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'cmpBy-inspect $ 'cmpBy `hasNoType` ''D.Step-#endif--{-# INLINE cmpByPure #-}-cmpByPure :: Int -> Int -> Identity P.Ordering-cmpByPure value n = cmpBy' (sourceUnfoldr value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'cmpByPure-inspect $ 'cmpByPure `hasNoType` ''D.Step-#endif------------------------------------------------------------------------------------ Streams of streams------------------------------------------------------------------------------------ Special cases of concatMap--{-# INLINE sourceFoldMapWith #-}-sourceFoldMapWith :: (S.IsStream t, S.Semigroup (t m Int))- => Int -> Int -> t m Int-sourceFoldMapWith value n = S.foldMapWith (S.<>) S.yield [n..n+value]--{-# INLINE sourceFoldMapWithM #-}-sourceFoldMapWithM :: (S.IsStream t, Monad m, S.Semigroup (t m Int))- => Int -> Int -> t m Int-sourceFoldMapWithM value n = S.foldMapWith (S.<>) (S.yieldM . return) [n..n+value]--{-# INLINE sourceFoldMapM #-}-sourceFoldMapM :: (S.IsStream t, Monad m, P.Monoid (t m Int))- => Int -> Int -> t m Int-sourceFoldMapM value n = F.foldMap (S.yieldM . return) [n..n+value]--{-# INLINE sourceConcatMapId #-}-sourceConcatMapId :: (S.IsStream t, Monad m)- => Int -> Int -> t m Int-sourceConcatMapId value n =- S.concatMap P.id $ S.fromFoldable $ P.map (S.yieldM . return) [n..n+value]---- concatMap unfoldrM/unfoldrM--{-# INLINE concatMap #-}-concatMap :: Int -> Int -> Int -> IO ()-concatMap outer inner n =- S.drain $ S.concatMap- (\_ -> sourceUnfoldrMN inner n)- (sourceUnfoldrMN outer n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMap-#endif---- concatMap unfoldr/unfoldr--{-# INLINE concatMapPure #-}-concatMapPure :: Int -> Int -> Int -> IO ()-concatMapPure outer inner n =- S.drain $ S.concatMap- (\_ -> sourceUnfoldrN inner n)- (sourceUnfoldrN outer n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapPure-#endif---- concatMap replicate/unfoldrM--{-# INLINE concatMapRepl4xN #-}-concatMapRepl4xN :: Int -> Int -> IO ()-concatMapRepl4xN value n = S.drain $ S.concatMap (S.replicate 4)- (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapRepl4xN-#endif---- concatMapWith--{-# INLINE concatStreamsWith #-}-concatStreamsWith- :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c)- -> Int- -> Int- -> Int- -> IO ()-concatStreamsWith op outer inner n =- S.drain $ S.concatMapWith op- (\i -> sourceUnfoldrMN inner i)- (sourceUnfoldrMN outer n)--{-# INLINE concatMapWithSerial #-}-concatMapWithSerial :: Int -> Int -> Int -> IO ()-concatMapWithSerial = concatStreamsWith S.serial--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapWithSerial-#endif--{-# INLINE concatMapWithAppend #-}-concatMapWithAppend :: Int -> Int -> Int -> IO ()-concatMapWithAppend = concatStreamsWith Internal.append--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapWithAppend-#endif--{-# INLINE concatMapWithWSerial #-}-concatMapWithWSerial :: Int -> Int -> Int -> IO ()-concatMapWithWSerial = concatStreamsWith S.wSerial--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapWithWSerial-#endif---- concatUnfold---- concatUnfold replicate/unfoldrM--{-# INLINE concatUnfoldRepl4xN #-}-concatUnfoldRepl4xN :: Int -> Int -> IO ()-concatUnfoldRepl4xN value n =- S.drain $ S.concatUnfold- (UF.replicateM 4)- (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatUnfoldRepl4xN-inspect $ 'concatUnfoldRepl4xN `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE concatUnfoldInterleaveRepl4xN #-}-concatUnfoldInterleaveRepl4xN :: Int -> Int -> IO ()-concatUnfoldInterleaveRepl4xN value n =- S.drain $ Internal.concatUnfoldInterleave- (UF.replicateM 4)- (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatUnfoldInterleaveRepl4xN--- inspect $ 'concatUnfoldInterleaveRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState-#endif--{-# INLINE concatUnfoldRoundrobinRepl4xN #-}-concatUnfoldRoundrobinRepl4xN :: Int -> Int -> IO ()-concatUnfoldRoundrobinRepl4xN value n =- S.drain $ Internal.concatUnfoldRoundrobin- (UF.replicateM 4)- (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatUnfoldRoundrobinRepl4xN--- inspect $ 'concatUnfoldRoundrobinRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState-#endif------------------------------------------------------------------------------------ Monad transformation (hoisting etc.)----------------------------------------------------------------------------------{-# INLINE sourceUnfoldrState #-}-sourceUnfoldrState :: (S.IsStream t, S.MonadAsync m)- => Int -> Int -> t (StateT Int m) Int-sourceUnfoldrState value n = S.unfoldrM step n- where- step cnt =- if cnt > n + value- then return Nothing- else do- s <- get- put (s + 1)- return (Just (s, cnt + 1))--{-# INLINE evalStateT #-}-evalStateT :: S.MonadAsync m => Int -> Int -> Stream m Int-evalStateT value n = Internal.evalStateT 0 (sourceUnfoldrState value n)--{-# INLINE withState #-}-withState :: S.MonadAsync m => Int -> Int -> Stream m Int-withState value n =- Internal.evalStateT (0 :: Int) (Internal.liftInner (sourceUnfoldrM value n))------------------------------------------------------------------------------------ Concurrent application/fold----------------------------------------------------------------------------------{-# INLINE parAppMap #-}-parAppMap :: S.MonadAsync m => Stream m Int -> m ()-parAppMap src = S.drain $ S.map (+1) S.|$ src--{-# INLINE parAppSum #-}-parAppSum :: S.MonadAsync m => Stream m Int -> m ()-parAppSum src = (S.sum S.|$. src) >>= \x -> P.seq x (return ())------------------------------------------------------------------------------------ Type class instances----------------------------------------------------------------------------------{-# INLINE eqInstance #-}-eqInstance :: Stream Identity Int -> Bool-eqInstance src = src == src--{-# INLINE eqInstanceNotEq #-}-eqInstanceNotEq :: Stream Identity Int -> Bool-eqInstanceNotEq src = src P./= src--{-# INLINE ordInstance #-}-ordInstance :: Stream Identity Int -> Bool-ordInstance src = src P.< src--{-# INLINE ordInstanceMin #-}-ordInstanceMin :: Stream Identity Int -> Stream Identity Int-ordInstanceMin src = P.min src src--{-# INLINE showInstance #-}-showInstance :: Stream Identity Int -> P.String-showInstance src = P.show src--{-# INLINE showInstanceList #-}-showInstanceList :: [Int] -> P.String-showInstanceList src = P.show src--{-# INLINE readInstance #-}-readInstance :: P.String -> Stream Identity Int-readInstance str =- let r = P.reads str- in case r of- [(x,"")] -> x- _ -> P.error "readInstance: no parse"--{-# INLINE readInstanceList #-}-readInstanceList :: P.String -> [Int]-readInstanceList str =- let r = P.reads str- in case r of- [(x,"")] -> x- _ -> P.error "readInstance: no parse"------------------------------------------------------------------------------------ Pure (Identity) streams----------------------------------------------------------------------------------{-# INLINE pureFoldl' #-}-pureFoldl' :: Stream Identity Int -> Int-pureFoldl' = runIdentity . S.foldl' (+) 0------------------------------------------------------------------------------------ Foldable Instance----------------------------------------------------------------------------------{-# INLINE foldableFoldl' #-}-foldableFoldl' :: Int -> Int -> Int-foldableFoldl' value n =- F.foldl' (+) 0 (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableFoldrElem #-}-foldableFoldrElem :: Int -> Int -> Bool-foldableFoldrElem value n =- F.foldr (\x xs -> if x == value then P.True else xs)- (P.False)- (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableSum #-}-foldableSum :: Int -> Int -> Int-foldableSum value n =- P.sum (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableProduct #-}-foldableProduct :: Int -> Int -> Int-foldableProduct value n =- P.product (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableNull #-}-foldableNull :: Int -> Int -> Bool-foldableNull value n =- P.null (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableElem #-}-foldableElem :: Int -> Int -> Bool-foldableElem value n =- P.elem value (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableNotElem #-}-foldableNotElem :: Int -> Int -> Bool-foldableNotElem value n =- P.notElem value (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableFind #-}-foldableFind :: Int -> Int -> Maybe Int-foldableFind value n =- F.find (== (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableAll #-}-foldableAll :: Int -> Int -> Bool-foldableAll value n =- P.all (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableAny #-}-foldableAny :: Int -> Int -> Bool-foldableAny value n =- P.any (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableAnd #-}-foldableAnd :: Int -> Int -> Bool-foldableAnd value n =- P.and $ S.map (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableOr #-}-foldableOr :: Int -> Int -> Bool-foldableOr value n =- P.or $ S.map (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableLength #-}-foldableLength :: Int -> Int -> Int-foldableLength value n =- P.length (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMin #-}-foldableMin :: Int -> Int -> Int-foldableMin value n =- P.minimum (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMax #-}-foldableMax :: Int -> Int -> Int-foldableMax value n =- P.maximum (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMinBy #-}-foldableMinBy :: Int -> Int -> Int-foldableMinBy value n =- F.minimumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableListMinBy #-}-foldableListMinBy :: Int -> Int -> Int-foldableListMinBy value n = F.minimumBy compare [1..value+n]--{-# INLINE foldableMaxBy #-}-foldableMaxBy :: Int -> Int -> Int-foldableMaxBy value n =- F.maximumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableToList #-}-foldableToList :: Int -> Int -> [Int]-foldableToList value n =- F.toList (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMapM_ #-}-foldableMapM_ :: Monad m => Int -> Int -> m ()-foldableMapM_ value n =- F.mapM_ (\_ -> return ()) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableSequence_ #-}-foldableSequence_ :: Int -> Int -> IO ()-foldableSequence_ value n =- F.sequence_ (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))--{-# INLINE foldableMsum #-}-foldableMsum :: Int -> Int -> IO Int-foldableMsum value n =- F.msum (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))------------------------------------------------------------------------------------ Traversable Instance----------------------------------------------------------------------------------{-# INLINE traversableTraverse #-}-traversableTraverse :: Stream Identity Int -> IO (Stream Identity Int)-traversableTraverse = P.traverse return--{-# INLINE traversableSequenceA #-}-traversableSequenceA :: Stream Identity Int -> IO (Stream Identity Int)-traversableSequenceA = P.sequenceA . P.fmap return--{-# INLINE traversableMapM #-}-traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)-traversableMapM = P.mapM return--{-# INLINE traversableSequence #-}-traversableSequence :: Stream Identity Int -> IO (Stream Identity Int)-traversableSequence = P.sequence . P.fmap return
+ benchmark/Streamly/Benchmark/Prelude/Adaptive.hs view
@@ -0,0 +1,132 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Control.Concurrent (threadDelay)+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Gauge+import Streamly+import Streamly.Prelude as S+import System.Random (randomRIO)++-- Note that we should also compare the cpuTime especially when threaded+-- runtime is used with this benchmark because thread scheduling is not+-- predictable and can add non-deterministic delay to the total time measured.+--+-- Also, the worker dispatch depends on the worker dispatch latency which is+-- set to fixed 200 us. We need to keep that in mind when designing tests.++value :: Int+value = 1000++{-# INLINE source #-}+source :: IsStream t => (Int, Int) -> t IO Int+source range = S.replicateM value $ do+ r <- randomRIO range+ when (r /= 0) $ liftIO $ threadDelay r+ return r++{-# INLINE run #-}+run :: IsStream t => (Int, Int) -> (Int, Int) -> (t IO Int -> SerialT IO Int) -> IO ()+run srange crange t = S.drain $ do+ n <- t $ source srange+ d <- liftIO (randomRIO crange)+ when (d /= 0) $ liftIO $ threadDelay d+ return n++low, medium, high :: Int+low = 10+medium = 20+high = 30++{-# INLINE noDelay #-}+noDelay :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+noDelay = run (0,0) (0,0)++{-# INLINE alwaysConstSlowSerial #-}+alwaysConstSlowSerial :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+alwaysConstSlowSerial = run (0,0) (medium,medium)++{-# INLINE alwaysConstSlow #-}+alwaysConstSlow :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+alwaysConstSlow = run (low,low) (medium,medium)++{-# INLINE alwaysConstFast #-}+alwaysConstFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+alwaysConstFast = run (high,high) (medium,medium)++{-# INLINE alwaysVarSlow #-}+alwaysVarSlow :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+alwaysVarSlow = run (low,low) (low,high)++{-# INLINE alwaysVarFast #-}+alwaysVarFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+alwaysVarFast = run (high,high) (low,high)++-- XXX add variable producer tests as well++{-# INLINE runVarSometimesFast #-}+runVarSometimesFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+runVarSometimesFast = run (medium,medium) (low,high)++{-# INLINE randomVar #-}+randomVar :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()+randomVar = run (low,high) (low,high)++main :: IO ()+main =+ defaultMain+ [+ bgroup "serialConstantSlowConsumer"+ [ bench "serially" $ nfIO $ alwaysConstSlowSerial serially+ , bench "wSerially" $ nfIO $ alwaysConstSlowSerial wSerially+ ]+ , bgroup "default"+ [ bench "serially" $ nfIO $ noDelay serially+ , bench "wSerially" $ nfIO $ noDelay wSerially+ , bench "aheadly" $ nfIO $ noDelay aheadly+ , bench "asyncly" $ nfIO $ noDelay asyncly+ , bench "wAsyncly" $ nfIO $ noDelay wAsyncly+ , bench "parallely" $ nfIO $ noDelay parallely+ ]+ , bgroup "constantSlowConsumer"+ [ bench "aheadly" $ nfIO $ alwaysConstSlow aheadly+ , bench "asyncly" $ nfIO $ alwaysConstSlow asyncly+ , bench "wAsyncly" $ nfIO $ alwaysConstSlow wAsyncly+ , bench "parallely" $ nfIO $ alwaysConstSlow parallely+ ]+ , bgroup "constantFastConsumer"+ [ bench "aheadly" $ nfIO $ alwaysConstFast aheadly+ , bench "asyncly" $ nfIO $ alwaysConstFast asyncly+ , bench "wAsyncly" $ nfIO $ alwaysConstFast wAsyncly+ , bench "parallely" $ nfIO $ alwaysConstFast parallely+ ]+ , bgroup "variableSlowConsumer"+ [ bench "aheadly" $ nfIO $ alwaysVarSlow aheadly+ , bench "asyncly" $ nfIO $ alwaysVarSlow asyncly+ , bench "wAsyncly" $ nfIO $ alwaysVarSlow wAsyncly+ , bench "parallely" $ nfIO $ alwaysVarSlow parallely+ ]+ , bgroup "variableFastConsumer"+ [ bench "aheadly" $ nfIO $ alwaysVarFast aheadly+ , bench "asyncly" $ nfIO $ alwaysVarFast asyncly+ , bench "wAsyncly" $ nfIO $ alwaysVarFast wAsyncly+ , bench "parallely" $ nfIO $ alwaysVarFast parallely+ ]+ , bgroup "variableSometimesFastConsumer"+ [ bench "aheadly" $ nfIO $ runVarSometimesFast aheadly+ , bench "asyncly" $ nfIO $ runVarSometimesFast asyncly+ , bench "wAsyncly" $ nfIO $ runVarSometimesFast wAsyncly+ , bench "parallely" $ nfIO $ runVarSometimesFast parallely+ ]+ , bgroup "variableFullOverlap"+ [ bench "aheadly" $ nfIO $ randomVar aheadly+ , bench "asyncly" $ nfIO $ randomVar asyncly+ , bench "wAsyncly" $ nfIO $ randomVar wAsyncly+ , bench "parallely" $ nfIO $ randomVar parallely+ ]+ ]
+ benchmark/Streamly/Benchmark/Prelude/Concurrent.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Control.Concurrent+import Control.Monad (when, replicateM)++import Gauge+import Streamly+import qualified Streamly.Prelude as S++-------------------------------------------------------------------------------+-- Append+-------------------------------------------------------------------------------++-- | Run @tcount@ number of actions concurrently using the given concurrency+-- style. Each thread produces a single output after a delay of @d@+-- microseconds.+--+{-# INLINE append #-}+append :: IsStream t+ => Int -> Int -> Int -> (t IO Int -> SerialT IO Int) -> IO ()+append buflen tcount d t =+ let work = (\i -> when (d /= 0) (threadDelay d) >> return i)+ in S.drain+ $ t+ $ maxBuffer buflen+ $ maxThreads (-1)+ $ S.fromFoldableM $ map work [1..tcount]++-- | Run @threads@ concurrently, each producing streams of @elems@ elements+-- with a delay of @d@ microseconds between successive elements, and merge+-- their outputs in a single output stream. The individual streams are produced+-- serially but merged using the provided concurrency style.+--+{-# INLINE concated #-}+concated+ :: Int+ -> Int+ -> Int+ -> Int+ -> (forall a. SerialT IO a -> SerialT IO a -> SerialT IO a)+ -> IO ()+concated buflen threads d elems t =+ let work = \i -> S.replicateM i+ ((when (d /= 0) (threadDelay d)) >> return i)+ in S.drain+ $ adapt+ $ maxThreads (-1)+ $ maxBuffer buflen+ $ S.concatMapWith t work+ $ S.replicate threads elems++appendGroup :: Int -> Int -> Int -> [Benchmark]+appendGroup buflen threads delay =+ [ -- bench "serial" $ nfIO $ append buflen threads delay serially+ bench "ahead" $ nfIO $ append buflen threads delay aheadly+ , bench "async" $ nfIO $ append buflen threads delay asyncly+ , bench "wAsync" $ nfIO $ append buflen threads delay wAsyncly+ , bench "parallel" $ nfIO $ append buflen threads delay parallely+ ]++concatGroup :: Int -> Int -> Int -> Int -> [Benchmark]+concatGroup buflen threads delay n =+ [ bench "serial" $ nfIO $ concated buflen threads delay n serial+ , bench "ahead" $ nfIO $ concated buflen threads delay n ahead+ , bench "async" $ nfIO $ concated buflen threads delay n async+ , bench "wAsync" $ nfIO $ concated buflen threads delay n wAsync+ , bench "parallel" $ nfIO $ concated buflen threads delay n parallel+ ]++main :: IO ()+main = do+ defaultMainWith (defaultConfig+ { timeLimit = Just 0+ , minSamples = Just 1+ , minDuration = 0+ , includeFirstIter = True+ , quickMode = True+ })++ [ -- bgroup "append/buf-1-threads-10k-0sec" (appendGroup 1 10000 0)+ -- , bgroup "append/buf-100-threads-100k-0sec" (appendGroup 100 100000 0)+ bgroup "stream1x10k/buf10k-threads10k-5sec" (appendGroup 10000 10000 5000000)+ -- bgroup "concat/buf-1-threads-100k-count-1" (concatGroup 1 100000 0 1)+ -- bgroup "concat/buf-1-threads-1-count-10m" (concatGroup 1 1 0 10000000)+ , bgroup "streams100x500k/buf100-threads100" (concatGroup 100 100 0 500000)++ , bench "forkIO/threads10k-5sec" $+ let delay = threadDelay 5000000+ count = 10000 :: Int+ list = [1..count]+ work i = delay >> return i+ in nfIO $ do+ ref <- newEmptyMVar+ mapM_ (\i -> forkIO $ work i >>=+ \j -> putMVar ref j) list+ replicateM 10000 (takeMVar ref)+ ]
+ benchmark/Streamly/Benchmark/Prelude/LinearAsync.hs view
@@ -0,0 +1,46 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)+ where+ allBenchmarks value =+ concat+ [ async value+ , wAsync value+ , ahead value+ , zipAsync value+ ]+ async value =+ concat+ [ o_1_space_async_generation value+ , o_1_space_async_concatFoldable value+ , o_1_space_async_concatMap value+ , o_1_space_async_transformation value+ ]+ wAsync value =+ concat+ [ o_1_space_wAsync_generation value+ , o_1_space_wAsync_concatFoldable value+ , o_1_space_wAsync_concatMap value+ , o_1_space_wAsync_transformation value+ ]+ ahead value =+ concat+ [ o_1_space_ahead_generation value+ , o_1_space_ahead_concatFoldable value+ , o_1_space_ahead_concatMap value+ , o_1_space_ahead_transformation value+ ]+ zipAsync = o_1_space_async_zip
+ benchmark/Streamly/Benchmark/Prelude/LinearRate.hs view
@@ -0,0 +1,24 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)++ where++ allBenchmarks value =+ concat+ [ o_1_space_async_avgRate value+ , o_1_space_ahead_avgRate value+ ]
+ benchmark/Streamly/Benchmark/Prelude/NestedConcurrent.hs view
@@ -0,0 +1,84 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Control.DeepSeq (NFData)+import Control.Monad (when)+import Data.Functor.Identity (Identity, runIdentity)+import System.Random (randomRIO)++import Streamly.Benchmark.Common (parseCLIOpts)++import Streamly+import Gauge++import qualified Streamly.Benchmark.Prelude.NestedOps as Ops++benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark+benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f++_benchId :: (NFData b) => String -> (Int -> Identity b) -> Benchmark+_benchId name f = bench name $ nf (\g -> runIdentity (g 1)) f++defaultStreamSize :: Int+defaultStreamSize = 100000++main :: IO ()+main = do+ -- XXX Fix indentation+ (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize+ let finiteCount = min linearCount defaultStreamSize+ when (finiteCount /= linearCount) $+ putStrLn $ "Limiting stream size to "+ ++ show defaultStreamSize+ ++ " for finite stream operations only"++ finiteCount `seq` linearCount `seq` runMode (mode cfg) cfg benches+ [+ bgroup "aheadly"+ [ benchIO "toNullAp" $ Ops.toNullAp linearCount aheadly+ , benchIO "toNull" $ Ops.toNull linearCount aheadly+ , benchIO "toNull3" $ Ops.toNull3 linearCount aheadly+ -- , benchIO "toList" $ Ops.toList linearCount aheadly+ -- XXX consumes too much stack space+ , benchIO "toListSome" $ Ops.toListSome linearCount aheadly+ , benchIO "filterAllOut" $ Ops.filterAllOut linearCount aheadly+ , benchIO "filterAllIn" $ Ops.filterAllIn linearCount aheadly+ , benchIO "filterSome" $ Ops.filterSome linearCount aheadly+ , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount aheadly+ ]++ , bgroup "asyncly"+ [ benchIO "toNullAp" $ Ops.toNullAp linearCount asyncly+ , benchIO "toNull" $ Ops.toNull linearCount asyncly+ , benchIO "toNull3" $ Ops.toNull3 linearCount asyncly+ -- , benchIO "toList" $ Ops.toList linearCount asyncly+ , benchIO "toListSome" $ Ops.toListSome linearCount asyncly+ , benchIO "filterAllOut" $ Ops.filterAllOut linearCount asyncly+ , benchIO "filterAllIn" $ Ops.filterAllIn linearCount asyncly+ , benchIO "filterSome" $ Ops.filterSome linearCount asyncly+ , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount asyncly+ ]++ , bgroup "zipAsyncly"+ [ benchIO "toNullAp" $ Ops.toNullAp linearCount zipAsyncly+ ]++ -- Operations that are not scalable to infinite streams+ , bgroup "finite"+ [ bgroup "wAsyncly"+ [ benchIO "toNullAp" $ Ops.toNullAp finiteCount wAsyncly+ , benchIO "toNull" $ Ops.toNull finiteCount wAsyncly+ , benchIO "toNull3" $ Ops.toNull3 finiteCount wAsyncly+ -- , benchIO "toList" $ Ops.toList finiteCount wAsyncly+ , benchIO "toListSome" $ Ops.toListSome finiteCount wAsyncly+ , benchIO "filterAllOut" $ Ops.filterAllOut finiteCount wAsyncly+ -- , benchIO "filterAllIn" $ Ops.filterAllIn finiteCount wAsyncly+ , benchIO "filterSome" $ Ops.filterSome finiteCount wAsyncly+ , benchIO "breakAfterSome" $ Ops.breakAfterSome finiteCount wAsyncly+ ]+ ]+ ]
+ benchmark/Streamly/Benchmark/Prelude/NestedOps.hs view
@@ -0,0 +1,174 @@+-- |+-- Module : BenchmarkOps+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : MIT+-- Maintainer : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Streamly.Benchmark.Prelude.NestedOps where++import Control.Exception (try)+import GHC.Exception (ErrorCall)++import qualified Streamly as S hiding (runStream)+import qualified Streamly.Prelude as S++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++type Stream m a = S.SerialT m a++{-# INLINE source #-}+source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+source = sourceUnfoldrM++-- Change this to "sourceUnfoldrM value n" for consistency+{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM n value = S.serially $ S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceUnfoldr start n = S.unfoldr step start+ where+ step cnt =+ if cnt > start + n+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.drain++{-# INLINE runToList #-}+runToList :: Monad m => Stream m a -> m [a]+runToList = S.toList++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++{-# INLINE toNullAp #-}+toNullAp+ :: (S.IsStream t, S.MonadAsync m, Applicative (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+toNullAp linearCount t start = runStream . t $+ (+) <$> source start nestedCount2 <*> source start nestedCount2+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE toNull #-}+toNull+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+toNull linearCount t start = runStream . t $ do+ x <- source start nestedCount2+ y <- source start nestedCount2+ return $ x + y+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE toNull3 #-}+toNull3+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+toNull3 linearCount t start = runStream . t $ do+ x <- source start nestedCount3+ y <- source start nestedCount3+ z <- source start nestedCount3+ return $ x + y + z+ where+ nestedCount3 = round (fromIntegral linearCount**(1/3::Double))++{-# INLINE toList #-}+toList+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]+toList linearCount t start = runToList . t $ do+ x <- source start nestedCount2+ y <- source start nestedCount2+ return $ x + y+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++-- Taking a specified number of elements is very expensive in logict so we have+-- a test to measure the same.+{-# INLINE toListSome #-}+toListSome+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]+toListSome linearCount t start =+ runToList . t $ S.take 10000 $ do+ x <- source start nestedCount2+ y <- source start nestedCount2+ return $ x + y+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE filterAllOut #-}+filterAllOut+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+filterAllOut linearCount t start = runStream . t $ do+ x <- source start nestedCount2+ y <- source start nestedCount2+ let s = x + y+ if s < 0+ then return s+ else S.nil+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE filterAllIn #-}+filterAllIn+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+filterAllIn linearCount t start = runStream . t $ do+ x <- source start nestedCount2+ y <- source start nestedCount2+ let s = x + y+ if s > 0+ then return s+ else S.nil+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE filterSome #-}+filterSome+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))+ => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+filterSome linearCount t start = runStream . t $ do+ x <- source start nestedCount2+ y <- source start nestedCount2+ let s = x + y+ if s > 1100000+ then return s+ else S.nil+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE breakAfterSome #-}+breakAfterSome+ :: (S.IsStream t, Monad (t IO))+ => Int -> (t IO Int -> S.SerialT IO Int) -> Int -> IO ()+breakAfterSome linearCount t start = do+ (_ :: Either ErrorCall ()) <- try $ runStream . t $ do+ x <- source start nestedCount2+ y <- source start nestedCount2+ let s = x + y+ if s > 1100000+ then error "break"+ else return s+ return ()+ where+ nestedCount2 = round (fromIntegral linearCount**(1/2::Double))
+ benchmark/Streamly/Benchmark/Prelude/Parallel.hs view
@@ -0,0 +1,35 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)++ where++ allBenchmarks value =+ concat+ [ linear value+ , nested value+ ]++ linear value =+ concat+ [ o_1_space_parallel_generation value+ , o_1_space_parallel_concatFoldable value+ -- , o_n_space_parallel_outerProductStreams+ , o_1_space_parallel_concatMap value+ , o_1_space_parallel_transformation value+ ]++ nested = o_1_space_parallel_outerProductStreams
+ benchmark/Streamly/Benchmark/Prelude/Serial/O_1_Space.hs view
@@ -0,0 +1,59 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)++ where++ allBenchmarks value =+ concat+ [ serial value+ , wSerial value+ , zipSerial value+ ]++ serial value =+ concat+ [ o_1_space_serial_pure value+ , o_1_space_serial_foldable value+ , o_1_space_serial_generation value+ , o_1_space_serial_elimination value+ , o_1_space_serial_foldMultiStream value+ , o_1_space_serial_pipes value+ , o_1_space_serial_pipesX4 value+ , o_1_space_serial_transformer value+ , o_1_space_serial_transformation value+ , o_1_space_serial_transformationX4 value+ , o_1_space_serial_filtering value+ , o_1_space_serial_filteringX4 value+ , o_1_space_serial_joining value+ , o_1_space_serial_concatFoldable value+ , o_1_space_serial_concatSerial value+ , o_1_space_serial_outerProductStreams value+ , o_1_space_serial_mixed value+ , o_1_space_serial_mixedX4 value+ ]++ wSerial value =+ concat+ [ o_1_space_wSerial_transformation value+ , o_1_space_wSerial_concatMap value+ , o_1_space_wSerial_outerProduct value+ ]++ zipSerial value = concat [o_1_space_zipSerial_transformation value]
+ benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Heap.hs view
@@ -0,0 +1,30 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ size <- limitStreamSize value+ size `seq` runMode (mode cfg) cfg benches (allBenchmarks size)++ where++ -- Operations using O(1) stack space and O(n) heap space.+ -- Tail recursive left folds+ allBenchmarks size =+ concat+ [ o_n_heap_serial_foldl size+ , o_n_heap_serial_buffering size+ ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Space.hs view
@@ -0,0 +1,31 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ size <- limitStreamSize value+ size `seq` runMode (mode cfg) cfg benches (allBenchmarks size)++ where++ allBenchmarks size =+ concat+ [ o_n_space_serial_toList size -- < 2MB+ , o_n_space_serial_outerProductStreams size+ , o_n_space_wSerial_outerProductStreams size+ , o_n_space_serial_traversable size -- < 2MB+ , o_n_space_serial_foldr size+ ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Stack.hs view
@@ -0,0 +1,26 @@+-- |+-- Module : Main+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+main :: IO ()+main = do+ (value, cfg, benches) <- parseCLIOpts defaultStreamSize+ size <- limitStreamSize value+ size `seq` runMode (mode cfg) cfg benches (allBenchmarks size)++ where++ -- Operations using O(n) stack space but O(1) heap space.+ -- Head recursive operations.+ allBenchmarks = o_n_stack_serial_iterated
+ benchmark/lib/Streamly/Benchmark/Common.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-orphans #-}+#endif++-- |+-- Module : Streamly.Benchmark.Common+-- Copyright : (c) 2019 Composewell Technologies+--+-- License : BSD3+-- Maintainer : streamly@composewell.com++module Streamly.Benchmark.Common+ ( parseCLIOpts++ , benchIOSink1+ , benchPure+ , benchPureSink1+ , benchFold++ , benchIOSrc1+ , benchPureSrc++ , mkString+ , mkList+ , mkListString++ , defaultStreamSize+ , limitStreamSize+ )+where++import Control.DeepSeq (NFData(..))+import Control.Exception (evaluate)+import Control.Monad (when)+import Data.Functor.Identity (Identity, runIdentity)+import Data.List (scanl')+import Data.Maybe (catMaybes)+import System.Console.GetOpt+ (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt')+import System.Environment (getArgs, lookupEnv, setEnv)+import Text.Read (readMaybe)+import System.Random (randomRIO)++import qualified Streamly.Prelude as S++import Streamly+import Gauge++-------------------------------------------------------------------------------+-- Benchmarking utilities+-------------------------------------------------------------------------------++#if !MIN_VERSION_deepseq(1,4,3)+instance NFData Ordering where rnf = (`seq` ())+#endif++-- XXX once we convert all the functions to use this we can rename this to+-- benchIOSink+{-# INLINE benchIOSink1 #-}+benchIOSink1 :: NFData b => String -> (Int -> IO b) -> Benchmark+benchIOSink1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f++{-# INLINE benchIOSrc1 #-}+benchIOSrc1 :: String -> (Int -> IO ()) -> Benchmark+benchIOSrc1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f++-- We need a monadic bind here to make sure that the function f does not get+-- completely optimized out by the compiler in some cases.+{-# INLINE benchFold #-}+benchFold :: NFData b+ => String -> (t IO Int -> IO b) -> (Int -> t IO Int) -> Benchmark+benchFold name f src = bench name $ nfIO $ randomRIO (1,1) >>= f . src++{-# INLINE benchPure #-}+benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark+benchPure name src f = bench name $ nfIO $ randomRIO (1,1) >>= return . f . src++-- XXX once we convert all the functions to use this we can rename this to+-- benchPureSink+{-# INLINE benchPureSink1 #-}+benchPureSink1 :: NFData b => String -> (Int -> Identity b) -> Benchmark+benchPureSink1 name f =+ bench name $ nfIO $ randomRIO (1,1) >>= return . runIdentity . f++{-# INLINE benchPureSrc #-}+benchPureSrc :: String -> (Int -> SerialT Identity a) -> Benchmark+benchPureSrc name src = benchPure name src (runIdentity . S.drain)++-------------------------------------------------------------------------------+-- String/List generation for read instances+-------------------------------------------------------------------------------++{-# INLINABLE mkString #-}+mkString :: Int -> String+mkString value = "fromList [1" ++ concat (replicate value ",1") ++ "]"++{-# INLINABLE mkListString #-}+mkListString :: Int -> String+mkListString value = "[1" ++ concat (replicate value ",1") ++ "]"++{-# INLINABLE mkList #-}+mkList :: Int -> [Int]+mkList value = [1..value]++-------------------------------------------------------------------------------+-- Stream size+-------------------------------------------------------------------------------++defaultStreamSize :: Int+defaultStreamSize = 100000++limitStreamSize :: Int -> IO Int+limitStreamSize value = do+ let val = min value defaultStreamSize+ when (val /= value) $+ putStrLn $ "Limiting stream size to "+ ++ show defaultStreamSize+ ++ " for non O(1) space operations"+ return val++-------------------------------------------------------------------------------+-- Parse custom CLI options+-------------------------------------------------------------------------------++data BenchOpts = StreamSize Int deriving Show++getStreamSize :: String -> Int+getStreamSize size =+ case (readMaybe size :: Maybe Int) of+ Just x -> x+ Nothing -> error "Stream size must be numeric"++options :: [OptDescr BenchOpts]+options =+ [+ Option [] ["stream-size"] (ReqArg getSize "COUNT") "Stream element count"+ ]++ where++ getSize = StreamSize . getStreamSize++deleteOptArgs+ :: (Maybe String, Maybe String) -- (prev, yielded)+ -> String+ -> (Maybe String, Maybe String)+deleteOptArgs (Nothing, _) opt =+ if opt == "--stream-size"+ then (Just opt, Nothing)+ else (Just opt, Just opt)++deleteOptArgs (Just prev, _) opt =+ if opt == "--stream-size" || prev == "--stream-size"+ then (Just opt, Nothing)+ else (Just opt, Just opt)++parseCLIOpts :: Int -> IO (Int, Config, [String])+parseCLIOpts defStreamSize = do+ args <- getArgs++ -- Parse custom options+ let (opts, _, _, errs) = getOpt' Permute options args+ when (not $ null errs) $ error $ concat errs+ (streamSize, args') <-+ case opts of+ StreamSize x : _ -> do+ -- When using the gauge "--measure-with" option we need to make+ -- sure that we pass the stream size to child process forked by+ -- gauge. So we use this env var for that purpose.+ setEnv "STREAM_SIZE" (show x)+ -- Hack! remove the option and its argument from args+ -- getOpt should have a way to return the unconsumed args in+ -- correct order.+ newArgs <-+ evaluate+ $ catMaybes+ $ map snd+ $ scanl' deleteOptArgs (Nothing, Nothing) args+ return (x, newArgs)+ _ -> do+ r <- lookupEnv "STREAM_SIZE"+ case r of+ Just x -> do+ s <- evaluate $ getStreamSize x+ return (s, args)+ Nothing -> return (defStreamSize, args)++ -- Parse gauge options+ let config = defaultConfig+ { timeLimit = Just 1+ , minDuration = 0+ , includeFirstIter = streamSize > defStreamSize+ }+ let (cfg, benches) = parseWith config args'+ streamSize `seq` return (streamSize, cfg, benches)
+ benchmark/lib/Streamly/Benchmark/Prelude.hs view
@@ -0,0 +1,2700 @@+-- |+-- Module : Streamly.Benchmark.Prelude+-- Copyright : (c) 2018 Harendra Kumar+--+-- License : MIT+-- Maintainer : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Streamly.Benchmark.Prelude+ -- TODO: export a single bench group for o_1_space_serial+ ( o_1_space_serial_pure+ , o_1_space_serial_foldable+ , o_1_space_serial_generation+ , o_1_space_serial_elimination+ , o_1_space_serial_foldMultiStream+ , o_1_space_serial_pipes+ , o_1_space_serial_pipesX4+ , o_1_space_serial_transformer+ , o_1_space_serial_transformation+ , o_1_space_serial_transformationX4+ , o_1_space_serial_filtering+ , o_1_space_serial_filteringX4+ , o_1_space_serial_joining+ , o_1_space_serial_concatFoldable+ , o_1_space_serial_concatSerial+ , o_1_space_serial_outerProductStreams+ , o_1_space_serial_mixed+ , o_1_space_serial_mixedX4++ , o_1_space_wSerial_transformation+ , o_1_space_wSerial_concatMap+ , o_1_space_wSerial_outerProduct++ , o_1_space_zipSerial_transformation++ , o_n_space_serial_toList+ , o_n_space_serial_outerProductStreams++ , o_n_space_wSerial_outerProductStreams++ , o_n_space_serial_traversable+ , o_n_space_serial_foldr++ , o_n_heap_serial_foldl+ , o_n_heap_serial_buffering++ , o_n_stack_serial_iterated++ , o_1_space_async_generation+ , o_1_space_async_concatFoldable+ , o_1_space_async_concatMap+ , o_1_space_async_transformation++ , o_1_space_wAsync_generation+ , o_1_space_wAsync_concatFoldable+ , o_1_space_wAsync_concatMap+ , o_1_space_wAsync_transformation++ , o_1_space_ahead_generation+ , o_1_space_ahead_concatFoldable+ , o_1_space_ahead_concatMap+ , o_1_space_ahead_transformation++ , o_1_space_async_zip++ -- TODO: rename to o_n_*+ , o_1_space_parallel_generation+ , o_1_space_parallel_concatFoldable+ , o_1_space_parallel_concatMap+ , o_1_space_parallel_transformation+ , o_1_space_parallel_outerProductStreams+ , o_n_space_parallel_outerProductStreams++ , o_1_space_async_avgRate++ , o_1_space_ahead_avgRate+ ) where++import Control.DeepSeq (NFData(..))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.State.Strict (StateT, get, put)+import Data.Functor.Identity (Identity, runIdentity)+import Data.IORef (newIORef, modifyIORef')+import GHC.Generics (Generic)+import System.Random (randomRIO)+import Prelude+ (Monad, String, Int, (+), ($), (.), return, even, (>), (<=), (==), (>=),+ subtract, undefined, Maybe(..), Bool, not, (>>=), curry,+ maxBound, div, IO, compare, Double, fromIntegral, Integer, (<$>),+ (<*>), flip, sqrt, round, (*), seq)+import qualified Prelude as P+import qualified Data.Foldable as F+import qualified GHC.Exts as GHC++#ifdef INSPECTION+import GHC.Types (SPEC(..))+import Test.Inspection++import qualified Streamly.Internal.Data.Stream.StreamD as D+#endif++import qualified Streamly as S hiding (runStream)+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Prelude as Internal+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.Data.Pipe as Pipe+import qualified Streamly.Internal.Data.Stream.Parallel as Par+import Streamly.Internal.Data.Time.Units++import qualified Streamly.Internal.Prelude as IP++import qualified Streamly.Benchmark.Prelude.NestedOps as Nested++import Gauge+import Streamly hiding (runStream)+import Streamly.Benchmark.Common++type Stream m a = S.SerialT m a++-------------------------------------------------------------------------------+-- Stream generation+-------------------------------------------------------------------------------++-- enumerate++{-# INLINE sourceIntFromTo #-}+sourceIntFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceIntFromTo value n = S.enumerateFromTo n (n + value)++{-# INLINE sourceIntFromThenTo #-}+sourceIntFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceIntFromThenTo value n = S.enumerateFromThenTo n (n + 1) (n + value)++{-# INLINE sourceFracFromTo #-}+sourceFracFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double+sourceFracFromTo value n =+ S.enumerateFromTo (fromIntegral n) (fromIntegral (n + value))++{-# INLINE sourceFracFromThenTo #-}+sourceFracFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double+sourceFracFromThenTo value n = S.enumerateFromThenTo (fromIntegral n)+ (fromIntegral n + 1.0001) (fromIntegral (n + value))++{-# INLINE sourceIntegerFromStep #-}+sourceIntegerFromStep :: (Monad m, S.IsStream t) => Int -> Int -> t m Integer+sourceIntegerFromStep value n =+ S.take value $ S.enumerateFromThen (fromIntegral n) (fromIntegral n + 1)++-- unfoldr++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceUnfoldr value n = S.unfoldr step n+ where+ step cnt =+ if cnt > n + value+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrN #-}+sourceUnfoldrN :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceUnfoldrN upto start = S.unfoldr step start+ where+ step cnt =+ if cnt > start + upto+ then Nothing+ else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM value n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE source #-}+source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+source = sourceUnfoldrM++{-# INLINE sourceUnfoldrMN #-}+sourceUnfoldrMN :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrMN upto start = S.unfoldrM step start+ where+ step cnt =+ if cnt > start + upto+ then return Nothing+ else return (Just (cnt, cnt + 1))++{-# INLINE sourceUnfoldrMAction #-}+sourceUnfoldrMAction :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (m Int)+sourceUnfoldrMAction value n = S.serially $ S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else return (Just (return cnt, cnt + 1))++{-# INLINE sourceUnfoldrAction #-}+sourceUnfoldrAction :: (S.IsStream t, Monad m, Monad m1)+ => Int -> Int -> t m (m1 Int)+sourceUnfoldrAction value n = S.serially $ S.unfoldr step n+ where+ step cnt =+ if cnt > n + value+ then Nothing+ else (Just (return cnt, cnt + 1))++-- fromIndices++{-# INLINE _sourceFromIndices #-}+_sourceFromIndices :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+_sourceFromIndices value n = S.take value $ S.fromIndices (+ n)++{-# INLINE _sourceFromIndicesM #-}+_sourceFromIndicesM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+_sourceFromIndicesM value n = S.take value $ S.fromIndicesM (P.fmap return (+ n))++-- fromList++{-# INLINE sourceFromList #-}+sourceFromList :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceFromList value n = S.fromList [n..n+value]++{-# INLINE sourceFromListM #-}+sourceFromListM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+sourceFromListM value n = S.fromListM (P.fmap return [n..n+value])++{-# INLINE sourceIsList #-}+sourceIsList :: Int -> Int -> S.SerialT Identity Int+sourceIsList value n = GHC.fromList [n..n+value]++{-# INLINE sourceIsString #-}+sourceIsString :: Int -> Int -> S.SerialT Identity P.Char+sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a')++-- fromFoldable++{-# INLINE sourceFromFoldable #-}+sourceFromFoldable :: S.IsStream t => Int -> Int -> t m Int+sourceFromFoldable value n = S.fromFoldable [n..n+value]++{-# INLINE sourceFromFoldableM #-}+sourceFromFoldableM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceFromFoldableM value n = S.fromFoldableM (P.fmap return [n..n+value])++{-# INLINE currentTime #-}+currentTime :: (S.IsStream t, S.MonadAsync m)+ => Int -> Double -> Int -> t m AbsTime+currentTime value g _ = S.take value $ Internal.currentTime g++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.drain++{-# INLINE toNull #-}+toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()+toNull t = runStream . t++{-# INLINE uncons #-}+uncons :: Monad m => Stream m Int -> m ()+uncons s = do+ r <- S.uncons s+ case r of+ Nothing -> return ()+ Just (_, t) -> uncons t++{-# INLINE init #-}+init :: Monad m => Stream m a -> m ()+init s = S.init s >>= P.mapM_ S.drain++{-# INLINE tail #-}+tail :: Monad m => Stream m a -> m ()+tail s = S.tail s >>= P.mapM_ tail++{-# INLINE nullHeadTail #-}+nullHeadTail :: Monad m => Stream m Int -> m ()+nullHeadTail s = do+ r <- S.null s+ when (not r) $ do+ _ <- S.head s+ S.tail s >>= P.mapM_ nullHeadTail++{-# INLINE mapM_ #-}+mapM_ :: Monad m => Stream m Int -> m ()+mapM_ = S.mapM_ (\_ -> return ())++{-# INLINE toList #-}+toList :: Monad m => Stream m Int -> m [Int]+toList = S.toList++{-# INLINE toListRev #-}+toListRev :: Monad m => Stream m Int -> m [Int]+toListRev = Internal.toListRev++{-# INLINE foldrMElem #-}+foldrMElem :: Monad m => Int -> Stream m Int -> m Bool+foldrMElem e m =+ S.foldrM+ (\x xs ->+ if x == e+ then return P.True+ else xs)+ (return P.False)+ m++{-# INLINE foldrMToStream #-}+foldrMToStream :: Monad m => Stream m Int -> m (Stream Identity Int)+foldrMToStream = S.foldr S.cons S.nil++{-# INLINE foldrMBuild #-}+foldrMBuild :: Monad m => Stream m Int -> m [Int]+foldrMBuild = S.foldrM (\x xs -> xs >>= return . (x :)) (return [])++{-# INLINE foldl'Build #-}+foldl'Build :: Monad m => Stream m Int -> m [Int]+foldl'Build = S.foldl' (flip (:)) []++{-# INLINE foldlM'Build #-}+foldlM'Build :: Monad m => Stream m Int -> m [Int]+foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []++{-# INLINE foldrMReduce #-}+foldrMReduce :: Monad m => Stream m Int -> m Int+foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0)++{-# INLINE foldl'Reduce #-}+foldl'Reduce :: Monad m => Stream m Int -> m Int+foldl'Reduce = S.foldl' (+) 0++{-# INLINE foldl'ReduceMap #-}+foldl'ReduceMap :: Monad m => Stream m Int -> m Int+foldl'ReduceMap = P.fmap (+ 1) . S.foldl' (+) 0++{-# INLINE foldl1'Reduce #-}+foldl1'Reduce :: Monad m => Stream m Int -> m (Maybe Int)+foldl1'Reduce = S.foldl1' (+)++{-# INLINE foldlM'Reduce #-}+foldlM'Reduce :: Monad m => Stream m Int -> m Int+foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0++{-# INLINE last #-}+last :: Monad m => Stream m Int -> m (Maybe Int)+last = S.last++{-# INLINE _null #-}+_null :: Monad m => Stream m Int -> m Bool+_null = S.null++{-# INLINE _head #-}+_head :: Monad m => Stream m Int -> m (Maybe Int)+_head = S.head++{-# INLINE elem #-}+elem :: Monad m => Int -> Stream m Int -> m Bool+elem value = S.elem (value + 1)++{-# INLINE notElem #-}+notElem :: Monad m => Int -> Stream m Int -> m Bool+notElem value = S.notElem (value + 1)++{-# INLINE length #-}+length :: Monad m => Stream m Int -> m Int+length = S.length++{-# INLINE all #-}+all :: Monad m => Int -> Stream m Int -> m Bool+all value = S.all (<= (value + 1))++{-# INLINE any #-}+any :: Monad m => Int -> Stream m Int -> m Bool+any value = S.any (> (value + 1))++{-# INLINE and #-}+and :: Monad m => Int -> Stream m Int -> m Bool+and value = S.and . S.map (<= (value + 1))++{-# INLINE or #-}+or :: Monad m => Int -> Stream m Int -> m Bool+or value = S.or . S.map (> (value + 1))++{-# INLINE find #-}+find :: Monad m => Int -> Stream m Int -> m (Maybe Int)+find value = S.find (== (value + 1))++{-# INLINE findIndex #-}+findIndex :: Monad m => Int -> Stream m Int -> m (Maybe Int)+findIndex value = S.findIndex (== (value + 1))++{-# INLINE elemIndex #-}+elemIndex :: Monad m => Int -> Stream m Int -> m (Maybe Int)+elemIndex value = S.elemIndex (value + 1)++{-# INLINE maximum #-}+maximum :: Monad m => Stream m Int -> m (Maybe Int)+maximum = S.maximum++{-# INLINE minimum #-}+minimum :: Monad m => Stream m Int -> m (Maybe Int)+minimum = S.minimum++{-# INLINE sum #-}+sum :: Monad m => Stream m Int -> m Int+sum = S.sum++{-# INLINE product #-}+product :: Monad m => Stream m Int -> m Int+product = S.product++{-# INLINE minimumBy #-}+minimumBy :: Monad m => Stream m Int -> m (Maybe Int)+minimumBy = S.minimumBy compare++{-# INLINE maximumBy #-}+maximumBy :: Monad m => Stream m Int -> m (Maybe Int)+maximumBy = S.maximumBy compare++-------------------------------------------------------------------------------+-- Transformation+-------------------------------------------------------------------------------++{-# INLINE transform #-}+transform :: Monad m => Stream m a -> m ()+transform = runStream++{-# INLINE composeN #-}+composeN ::+ MonadIO m+ => Int+ -> (Stream m Int -> Stream m Int)+ -> Stream m Int+ -> m ()+composeN n f =+ case n of+ 1 -> transform . f+ 2 -> transform . f . f+ 3 -> transform . f . f . f+ 4 -> transform . f . f . f . f+ _ -> undefined++-- polymorphic stream version of composeN+{-# INLINE composeN' #-}+composeN' ::+ (S.IsStream t, Monad m)+ => Int+ -> (t m Int -> Stream m Int)+ -> t m Int+ -> m ()+composeN' n f =+ case n of+ 1 -> transform . f+ 2 -> transform . f . S.adapt . f+ 3 -> transform . f . S.adapt . f . S.adapt . f+ 4 -> transform . f . S.adapt . f . S.adapt . f . S.adapt . f+ _ -> undefined++{-# INLINE scan #-}+scan :: MonadIO m => Int -> Stream m Int -> m ()+scan n = composeN n $ S.scanl' (+) 0++{-# INLINE scanl1' #-}+scanl1' :: MonadIO m => Int -> Stream m Int -> m ()+scanl1' n = composeN n $ S.scanl1' (+)++{-# INLINE fmap #-}+fmap :: MonadIO m => Int -> Stream m Int -> m ()+fmap n = composeN n $ P.fmap (+ 1)++{-# INLINE fmap' #-}+fmap' ::+ (S.IsStream t, S.MonadAsync m, P.Functor (t m))+ => (t m Int -> S.SerialT m Int)+ -> Int+ -> t m Int+ -> m ()+fmap' t n = composeN' n $ t . P.fmap (+ 1)++{-# INLINE map #-}+map :: MonadIO m => Int -> Stream m Int -> m ()+map n = composeN n $ S.map (+ 1)++{-# INLINE map' #-}+map' ::+ (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int)+ -> Int+ -> t m Int+ -> m ()+map' t n = composeN' n $ t . S.map (+ 1)++{-# INLINE mapM #-}+mapM ::+ (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int)+ -> Int+ -> t m Int+ -> m ()+mapM t n = composeN' n $ t . S.mapM return++{-# INLINE tap #-}+tap :: MonadIO m => Int -> Stream m Int -> m ()+tap n = composeN n $ S.tap FL.sum++{-# INLINE tapRate #-}+tapRate :: Int -> Stream IO Int -> IO ()+tapRate n str = do+ cref <- newIORef 0+ composeN n (Internal.tapRate 1 (\c -> modifyIORef' cref (c +))) str++{-# INLINE pollCounts #-}+pollCounts :: Int -> Stream IO Int -> IO ()+pollCounts n str = do+ composeN n (Internal.pollCounts (P.const P.True) f FL.drain) str+ where+ f = Internal.rollingMap (P.-) . Internal.delayPost 1++{-# INLINE tapAsyncS #-}+tapAsyncS :: S.MonadAsync m => Int -> Stream m Int -> m ()+tapAsyncS n = composeN n $ Par.tapAsync S.sum++{-# INLINE tapAsync #-}+tapAsync :: S.MonadAsync m => Int -> Stream m Int -> m ()+tapAsync n = composeN n $ Internal.tapAsync FL.sum++{-# INLINE mapMaybe #-}+mapMaybe :: MonadIO m => Int -> Stream m Int -> m ()+mapMaybe n =+ composeN n $+ S.mapMaybe+ (\x ->+ if P.odd x+ then Nothing+ else Just x)++{-# INLINE mapMaybeM #-}+mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m ()+mapMaybeM n =+ composeN n $+ S.mapMaybeM+ (\x ->+ if P.odd x+ then return Nothing+ else return $ Just x)++{-# INLINE sequence #-}+sequence ::+ (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int)+ -> t m (m Int)+ -> m ()+sequence t = transform . t . S.sequence++{-# INLINE filterEven #-}+filterEven :: MonadIO m => Int -> Stream m Int -> m ()+filterEven n = composeN n $ S.filter even++{-# INLINE filterAllOut #-}+filterAllOut :: MonadIO m => Int -> Int -> Stream m Int -> m ()+filterAllOut value n = composeN n $ S.filter (> (value + 1))++{-# INLINE filterAllIn #-}+filterAllIn :: MonadIO m => Int -> Int -> Stream m Int -> m ()+filterAllIn value n = composeN n $ S.filter (<= (value + 1))++{-# INLINE _takeOne #-}+_takeOne :: MonadIO m => Int -> Stream m Int -> m ()+_takeOne n = composeN n $ S.take 1++{-# INLINE takeAll #-}+takeAll :: MonadIO m => Int -> Int -> Stream m Int -> m ()+takeAll value n = composeN n $ S.take (value + 1)++{-# INLINE takeWhileTrue #-}+takeWhileTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()+takeWhileTrue value n = composeN n $ S.takeWhile (<= (value + 1))++{-# INLINE _takeWhileMTrue #-}+_takeWhileMTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()+_takeWhileMTrue value n = composeN n $ S.takeWhileM (return . (<= (value + 1)))++{-# INLINE dropOne #-}+dropOne :: MonadIO m => Int -> Stream m Int -> m ()+dropOne n = composeN n $ S.drop 1++{-# INLINE dropAll #-}+dropAll :: MonadIO m => Int -> Int -> Stream m Int -> m ()+dropAll value n = composeN n $ S.drop (value + 1)++{-# INLINE dropWhileTrue #-}+dropWhileTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()+dropWhileTrue value n = composeN n $ S.dropWhile (<= (value + 1))++{-# INLINE _dropWhileMTrue #-}+_dropWhileMTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()+_dropWhileMTrue value n = composeN n $ S.dropWhileM (return . (<= (value + 1)))++{-# INLINE dropWhileFalse #-}+dropWhileFalse :: MonadIO m => Int -> Int -> Stream m Int -> m ()+dropWhileFalse value n = composeN n $ S.dropWhile (> (value + 1))++{-# INLINE findIndices #-}+findIndices :: MonadIO m => Int -> Int -> Stream m Int -> m ()+findIndices value n = composeN n $ S.findIndices (== (value + 1))++{-# INLINE elemIndices #-}+elemIndices :: MonadIO m => Int -> Int -> Stream m Int -> m ()+elemIndices value n = composeN n $ S.elemIndices (value + 1)++{-# INLINE intersperse #-}+intersperse :: S.MonadAsync m => Int -> Int -> Stream m Int -> m ()+intersperse value n = composeN n $ S.intersperse (value + 1)++{-# INLINE insertBy #-}+insertBy :: MonadIO m => Int -> Int -> Stream m Int -> m ()+insertBy value n = composeN n $ S.insertBy compare (value + 1)++{-# INLINE deleteBy #-}+deleteBy :: MonadIO m => Int -> Int -> Stream m Int -> m ()+deleteBy value n = composeN n $ S.deleteBy (>=) (value + 1)++{-# INLINE reverse #-}+reverse :: MonadIO m => Int -> Stream m Int -> m ()+reverse n = composeN n $ S.reverse++{-# INLINE reverse' #-}+reverse' :: MonadIO m => Int -> Stream m Int -> m ()+reverse' n = composeN n $ Internal.reverse'++{-# INLINE foldrS #-}+foldrS :: MonadIO m => Int -> Stream m Int -> m ()+foldrS n = composeN n $ Internal.foldrS S.cons S.nil++{-# INLINE foldrSMap #-}+foldrSMap :: MonadIO m => Int -> Stream m Int -> m ()+foldrSMap n = composeN n $ Internal.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil++{-# INLINE foldrT #-}+foldrT :: MonadIO m => Int -> Stream m Int -> m ()+foldrT n = composeN n $ Internal.foldrT S.cons S.nil++{-# INLINE foldrTMap #-}+foldrTMap :: MonadIO m => Int -> Stream m Int -> m ()+foldrTMap n = composeN n $ Internal.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil++{-# INLINE takeByTime #-}+takeByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO ()+takeByTime i n = composeN n (Internal.takeByTime i)++#ifdef INSPECTION+-- inspect $ hasNoType 'takeByTime ''SPEC+inspect $ hasNoTypeClasses 'takeByTime+-- inspect $ 'takeByTime `hasNoType` ''D.Step+#endif++{-# INLINE dropByTime #-}+dropByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO ()+dropByTime i n = composeN n (Internal.dropByTime i)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'dropByTime+-- inspect $ 'dropByTime `hasNoType` ''D.Step+#endif++-------------------------------------------------------------------------------+-- Pipes+-------------------------------------------------------------------------------++{-# INLINE transformMapM #-}+transformMapM ::+ (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int)+ -> Int+ -> t m Int+ -> m ()+transformMapM t n = composeN' n $ t . Internal.transform (Pipe.mapM return)++{-# INLINE transformComposeMapM #-}+transformComposeMapM ::+ (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int)+ -> Int+ -> t m Int+ -> m ()+transformComposeMapM t n =+ composeN' n $+ t .+ Internal.transform+ (Pipe.mapM (\x -> return (x + 1)) `Pipe.compose`+ Pipe.mapM (\x -> return (x + 2)))++{-# INLINE transformTeeMapM #-}+transformTeeMapM ::+ (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int)+ -> Int+ -> t m Int+ -> m ()+transformTeeMapM t n =+ composeN' n $+ t .+ Internal.transform+ (Pipe.mapM (\x -> return (x + 1)) `Pipe.tee`+ Pipe.mapM (\x -> return (x + 2)))++{-# INLINE transformZipMapM #-}+transformZipMapM ::+ (S.IsStream t, S.MonadAsync m)+ => (t m Int -> S.SerialT m Int)+ -> Int+ -> t m Int+ -> m ()+transformZipMapM t n =+ composeN' n $+ t .+ Internal.transform+ (Pipe.zipWith+ (+)+ (Pipe.mapM (\x -> return (x + 1)))+ (Pipe.mapM (\x -> return (x + 2))))++-------------------------------------------------------------------------------+-- Mixed Transformation+-------------------------------------------------------------------------------++{-# INLINE scanMap #-}+scanMap :: MonadIO m => Int -> Stream m Int -> m ()+scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0++{-# INLINE dropMap #-}+dropMap :: MonadIO m => Int -> Stream m Int -> m ()+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1++{-# INLINE dropScan #-}+dropScan :: MonadIO m => Int -> Stream m Int -> m ()+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1++{-# INLINE takeDrop #-}+takeDrop :: MonadIO m => Int -> Int -> Stream m Int -> m ()+takeDrop value n = composeN n $ S.drop 1 . S.take (value + 1)++{-# INLINE takeScan #-}+takeScan :: MonadIO m => Int -> Int -> Stream m Int -> m ()+takeScan value n = composeN n $ S.scanl' (+) 0 . S.take (value + 1)++{-# INLINE takeMap #-}+takeMap :: MonadIO m => Int -> Int -> Stream m Int -> m ()+takeMap value n = composeN n $ S.map (subtract 1) . S.take (value + 1)++{-# INLINE filterDrop #-}+filterDrop :: MonadIO m => Int -> Int -> Stream m Int -> m ()+filterDrop value n = composeN n $ S.drop 1 . S.filter (<= (value + 1))++{-# INLINE filterTake #-}+filterTake :: MonadIO m => Int -> Int -> Stream m Int -> m ()+filterTake value n = composeN n $ S.take (value + 1) . S.filter (<= (value + 1))++{-# INLINE filterScan #-}+filterScan :: MonadIO m => Int -> Stream m Int -> m ()+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)++{-# INLINE filterScanl1 #-}+filterScanl1 :: MonadIO m => Int -> Stream m Int -> m ()+filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)++{-# INLINE filterMap #-}+filterMap :: MonadIO m => Int -> Int -> Stream m Int -> m ()+filterMap value n = composeN n $ S.map (subtract 1) . S.filter (<= (value + 1))++-------------------------------------------------------------------------------+-- Scan and fold+-------------------------------------------------------------------------------++data Pair a b =+ Pair !a !b+ deriving (Generic, NFData)++{-# INLINE sumProductFold #-}+sumProductFold :: Monad m => Stream m Int -> m (Int, Int)+sumProductFold = S.foldl' (\(s, p) x -> (s + x, p P.* x)) (0, 1)++{-# INLINE sumProductScan #-}+sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)+sumProductScan =+ S.foldl' (\(Pair _ p) (s0, x) -> Pair s0 (p P.* x)) (Pair 0 1) .+ S.scanl' (\(s, _) x -> (s + x, x)) (0, 0)++-------------------------------------------------------------------------------+-- Iteration+-------------------------------------------------------------------------------++{-# INLINE iterStreamLen #-}+iterStreamLen :: Int+iterStreamLen = 10++{-# INLINE maxIters #-}+maxIters :: Int+maxIters = 10000++{-# INLINE iterateSource #-}+iterateSource ::+ S.MonadAsync m+ => (Stream m Int -> Stream m Int)+ -> Int+ -> Int+ -> Stream m Int+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)+ where+ f (0 :: Int) m = g m+ f x m = g (f (x P.- 1) m)++-- this is quadratic+{-# INLINE iterateScan #-}+iterateScan :: S.MonadAsync m => Int -> Stream m Int+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)++-- this is quadratic+{-# INLINE iterateScanl1 #-}+iterateScanl1 :: S.MonadAsync m => Int -> Stream m Int+iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10)++{-# INLINE iterateMapM #-}+iterateMapM :: S.MonadAsync m => Int -> Stream m Int+iterateMapM = iterateSource (S.mapM return) maxIters++{-# INLINE iterateFilterEven #-}+iterateFilterEven :: S.MonadAsync m => Int -> Stream m Int+iterateFilterEven = iterateSource (S.filter even) maxIters++{-# INLINE iterateTakeAll #-}+iterateTakeAll :: S.MonadAsync m => Int -> Int -> Stream m Int+iterateTakeAll value = iterateSource (S.take (value + 1)) maxIters++{-# INLINE iterateDropOne #-}+iterateDropOne :: S.MonadAsync m => Int -> Stream m Int+iterateDropOne = iterateSource (S.drop 1) maxIters++{-# INLINE iterateDropWhileFalse #-}+iterateDropWhileFalse :: S.MonadAsync m => Int -> Int -> Stream m Int+iterateDropWhileFalse value =+ iterateSource (S.dropWhile (> (value + 1))) maxIters++{-# INLINE iterateDropWhileTrue #-}+iterateDropWhileTrue :: S.MonadAsync m => Int -> Int -> Stream m Int+iterateDropWhileTrue value =+ iterateSource (S.dropWhile (<= (value + 1))) maxIters++-------------------------------------------------------------------------------+-- Combining streams+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Appending+-------------------------------------------------------------------------------++{-# INLINE serial2 #-}+serial2 :: Int -> Int -> IO ()+serial2 count n =+ S.drain $ S.serial (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))++{-# INLINE serial4 #-}+serial4 :: Int -> Int -> IO ()+serial4 count n =+ S.drain $+ S.serial+ ((S.serial (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))))+ ((S.serial+ (sourceUnfoldrMN count (n + 2))+ (sourceUnfoldrMN count (n + 3))))++{-# INLINE append2 #-}+append2 :: Int -> Int -> IO ()+append2 count n =+ S.drain $+ Internal.append (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))++{-# INLINE append4 #-}+append4 :: Int -> Int -> IO ()+append4 count n =+ S.drain $+ Internal.append+ ((Internal.append+ (sourceUnfoldrMN count n)+ (sourceUnfoldrMN count (n + 1))))+ ((Internal.append+ (sourceUnfoldrMN count (n + 2))+ (sourceUnfoldrMN count (n + 3))))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'append2+inspect $ 'append2 `hasNoType` ''SPEC+inspect $ 'append2 `hasNoType` ''D.AppendState+#endif++-------------------------------------------------------------------------------+-- Interleaving+-------------------------------------------------------------------------------++{-# INLINE wSerial2 #-}+wSerial2 :: Int -> Int -> IO ()+wSerial2 value n =+ S.drain $+ S.wSerial+ (sourceUnfoldrMN (value `div` 2) n)+ (sourceUnfoldrMN (value `div` 2) (n + 1))++{-# INLINE interleave2 #-}+interleave2 :: Int -> Int -> IO ()+interleave2 value n =+ S.drain $+ Internal.interleave+ (sourceUnfoldrMN (value `div` 2) n)+ (sourceUnfoldrMN (value `div` 2) (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'interleave2+inspect $ 'interleave2 `hasNoType` ''SPEC+inspect $ 'interleave2 `hasNoType` ''D.InterleaveState+#endif++{-# INLINE roundRobin2 #-}+roundRobin2 :: Int -> Int -> IO ()+roundRobin2 value n =+ S.drain $+ Internal.roundrobin+ (sourceUnfoldrMN (value `div` 2) n)+ (sourceUnfoldrMN (value `div` 2) (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'roundRobin2+inspect $ 'roundRobin2 `hasNoType` ''SPEC+inspect $ 'roundRobin2 `hasNoType` ''D.InterleaveState+#endif++-------------------------------------------------------------------------------+-- Merging+-------------------------------------------------------------------------------++{-# INLINE mergeBy #-}+mergeBy :: Int -> Int -> IO ()+mergeBy count n =+ S.drain $+ S.mergeBy+ P.compare+ (sourceUnfoldrMN count n)+ (sourceUnfoldrMN count (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'mergeBy+inspect $ 'mergeBy `hasNoType` ''SPEC+inspect $ 'mergeBy `hasNoType` ''D.Step+#endif++-------------------------------------------------------------------------------+-- Zipping+-------------------------------------------------------------------------------++{-# INLINE zip #-}+zip :: Int -> Int -> IO ()+zip count n =+ S.drain $+ S.zipWith (,) (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'zip+inspect $ 'zip `hasNoType` ''SPEC+inspect $ 'zip `hasNoType` ''D.Step+#endif++{-# INLINE zipM #-}+zipM :: Int -> Int -> IO ()+zipM count n =+ S.drain $+ S.zipWithM+ (curry return)+ (sourceUnfoldrMN count n)+ (sourceUnfoldrMN count (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'zipM+inspect $ 'zipM `hasNoType` ''SPEC+inspect $ 'zipM `hasNoType` ''D.Step+#endif++{-# INLINE zipAsync #-}+zipAsync :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)+zipAsync count n = do+ S.zipAsyncWith (,) (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))++{-# INLINE zipAsyncM #-}+zipAsyncM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)+zipAsyncM count n = do+ S.zipAsyncWithM+ (curry return)+ (sourceUnfoldrMN count n)+ (sourceUnfoldrMN count (n + 1))++{-# INLINE zipAsyncAp #-}+zipAsyncAp :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)+zipAsyncAp count n = do+ S.zipAsyncly $+ (,) <$> (sourceUnfoldrMN count n) <*> (sourceUnfoldrMN count (n + 1))++{-# INLINE mergeAsyncByM #-}+mergeAsyncByM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+mergeAsyncByM count n = do+ S.mergeAsyncByM+ (\a b -> return (a `compare` b))+ (sourceUnfoldrMN count n)+ (sourceUnfoldrMN count (n + 1))++{-# INLINE mergeAsyncBy #-}+mergeAsyncBy :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+mergeAsyncBy count n = do+ S.mergeAsyncBy+ compare+ (sourceUnfoldrMN count n)+ (sourceUnfoldrMN count (n + 1))++-------------------------------------------------------------------------------+-- Multi-stream folds+-------------------------------------------------------------------------------++{-# INLINE isPrefixOf #-}+isPrefixOf :: Monad m => Stream m Int -> m Bool+isPrefixOf src = S.isPrefixOf src src++{-# INLINE isSubsequenceOf #-}+isSubsequenceOf :: Monad m => Stream m Int -> m Bool+isSubsequenceOf src = S.isSubsequenceOf src src++{-# INLINE stripPrefix #-}+stripPrefix :: Monad m => Stream m Int -> m ()+stripPrefix src = do+ _ <- S.stripPrefix src src+ return ()++{-# INLINE eqBy' #-}+eqBy' :: (Monad m, P.Eq a) => Stream m a -> m P.Bool+eqBy' src = S.eqBy (==) src src++{-# INLINE eqBy #-}+eqBy :: Int -> Int -> IO Bool+eqBy value n = eqBy' (source value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'eqBy+inspect $ 'eqBy `hasNoType` ''SPEC+inspect $ 'eqBy `hasNoType` ''D.Step+#endif+++{-# INLINE eqByPure #-}+eqByPure :: Int -> Int -> Identity Bool+eqByPure value n = eqBy' (sourceUnfoldr value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'eqByPure+inspect $ 'eqByPure `hasNoType` ''SPEC+inspect $ 'eqByPure `hasNoType` ''D.Step+#endif++{-# INLINE cmpBy' #-}+cmpBy' :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering+cmpBy' src = S.cmpBy P.compare src src++{-# INLINE cmpBy #-}+cmpBy :: Int -> Int -> IO P.Ordering+cmpBy value n = cmpBy' (source value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'cmpBy+inspect $ 'cmpBy `hasNoType` ''SPEC+inspect $ 'cmpBy `hasNoType` ''D.Step+#endif++{-# INLINE cmpByPure #-}+cmpByPure :: Int -> Int -> Identity P.Ordering+cmpByPure value n = cmpBy' (sourceUnfoldr value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'cmpByPure+inspect $ 'cmpByPure `hasNoType` ''SPEC+inspect $ 'cmpByPure `hasNoType` ''D.Step+#endif++-------------------------------------------------------------------------------+-- Streams of streams+-------------------------------------------------------------------------------++-- Special cases of concatMap++{-# INLINE sourceFoldMapWith #-}+sourceFoldMapWith :: (S.IsStream t, S.Semigroup (t m Int))+ => Int -> Int -> t m Int+sourceFoldMapWith value n = S.foldMapWith (S.<>) S.yield [n..n+value]++{-# INLINE sourceFoldMapWithM #-}+sourceFoldMapWithM :: (S.IsStream t, Monad m, S.Semigroup (t m Int))+ => Int -> Int -> t m Int+sourceFoldMapWithM value n = S.foldMapWith (S.<>) (S.yieldM . return) [n..n+value]++{-# INLINE sourceFoldMapM #-}+sourceFoldMapM :: (S.IsStream t, Monad m, P.Monoid (t m Int))+ => Int -> Int -> t m Int+sourceFoldMapM value n = F.foldMap (S.yieldM . return) [n..n+value]++{-# INLINE sourceConcatMapId #-}+sourceConcatMapId :: (S.IsStream t, Monad m)+ => Int -> Int -> t m Int+sourceConcatMapId value n =+ S.concatMap P.id $ S.fromFoldable $ P.map (S.yieldM . return) [n..n+value]++-- concatMap unfoldrM/unfoldrM++{-# INLINE concatMap #-}+concatMap :: Int -> Int -> Int -> IO ()+concatMap outer inner n =+ S.drain $ S.concatMap+ (\_ -> sourceUnfoldrMN inner n)+ (sourceUnfoldrMN outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMap+inspect $ 'concatMap `hasNoType` ''SPEC+#endif++-- concatMap unfoldr/unfoldr++{-# INLINE concatMapPure #-}+concatMapPure :: Int -> Int -> Int -> IO ()+concatMapPure outer inner n =+ S.drain $ S.concatMap+ (\_ -> sourceUnfoldrN inner n)+ (sourceUnfoldrN outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapPure+inspect $ 'concatMapPure `hasNoType` ''SPEC+#endif++-- concatMap replicate/unfoldrM++{-# INLINE concatMapRepl4xN #-}+concatMapRepl4xN :: Int -> Int -> IO ()+concatMapRepl4xN value n = S.drain $ S.concatMap (S.replicate 4)+ (sourceUnfoldrMN (value `div` 4) n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapRepl4xN+inspect $ 'concatMapRepl4xN `hasNoType` ''SPEC+#endif++-- concatMapWith++{-# INLINE concatStreamsWith #-}+concatStreamsWith+ :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c)+ -> Int+ -> Int+ -> Int+ -> IO ()+concatStreamsWith op outer inner n =+ S.drain $ S.concatMapWith op+ (\i -> sourceUnfoldrMN inner i)+ (sourceUnfoldrMN outer n)++{-# INLINE concatMapWithSerial #-}+concatMapWithSerial :: Int -> Int -> Int -> IO ()+concatMapWithSerial = concatStreamsWith S.serial++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapWithSerial+inspect $ 'concatMapWithSerial `hasNoType` ''SPEC+#endif++{-# INLINE concatMapWithAppend #-}+concatMapWithAppend :: Int -> Int -> Int -> IO ()+concatMapWithAppend = concatStreamsWith Internal.append++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapWithAppend+inspect $ 'concatMapWithAppend `hasNoType` ''SPEC+#endif++{-# INLINE concatMapWithWSerial #-}+concatMapWithWSerial :: Int -> Int -> Int -> IO ()+concatMapWithWSerial = concatStreamsWith S.wSerial++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapWithWSerial+inspect $ 'concatMapWithSerial `hasNoType` ''SPEC+#endif++-- concatUnfold++-- concatUnfold replicate/unfoldrM++{-# INLINE concatUnfoldRepl4xN #-}+concatUnfoldRepl4xN :: Int -> Int -> IO ()+concatUnfoldRepl4xN value n =+ S.drain $ S.concatUnfold+ (UF.replicateM 4)+ (sourceUnfoldrMN (value `div` 4) n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatUnfoldRepl4xN+inspect $ 'concatUnfoldRepl4xN `hasNoType` ''D.ConcatMapUState+inspect $ 'concatUnfoldRepl4xN `hasNoType` ''SPEC+#endif++{-# INLINE concatUnfoldInterleaveRepl4xN #-}+concatUnfoldInterleaveRepl4xN :: Int -> Int -> IO ()+concatUnfoldInterleaveRepl4xN value n =+ S.drain $ Internal.concatUnfoldInterleave+ (UF.replicateM 4)+ (sourceUnfoldrMN (value `div` 4) n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatUnfoldInterleaveRepl4xN+-- inspect $ 'concatUnfoldInterleaveRepl4xN `hasNoType` ''SPEC+-- inspect $ 'concatUnfoldInterleaveRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState+#endif++{-# INLINE concatUnfoldRoundrobinRepl4xN #-}+concatUnfoldRoundrobinRepl4xN :: Int -> Int -> IO ()+concatUnfoldRoundrobinRepl4xN value n =+ S.drain $ Internal.concatUnfoldRoundrobin+ (UF.replicateM 4)+ (sourceUnfoldrMN (value `div` 4) n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatUnfoldRoundrobinRepl4xN+-- inspect $ 'concatUnfoldRoundrobinRepl4xN `hasNoType` ''SPEC+-- inspect $ 'concatUnfoldRoundrobinRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState+#endif++-------------------------------------------------------------------------------+-- Monad transformation (hoisting etc.)+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldrState #-}+sourceUnfoldrState :: (S.IsStream t, S.MonadAsync m)+ => Int -> Int -> t (StateT Int m) Int+sourceUnfoldrState value n = S.unfoldrM step n+ where+ step cnt =+ if cnt > n + value+ then return Nothing+ else do+ s <- get+ put (s + 1)+ return (Just (s, cnt + 1))++{-# INLINE evalStateT #-}+evalStateT :: S.MonadAsync m => Int -> Int -> Stream m Int+evalStateT value n = Internal.evalStateT 0 (sourceUnfoldrState value n)++{-# INLINE withState #-}+withState :: S.MonadAsync m => Int -> Int -> Stream m Int+withState value n =+ Internal.evalStateT (0 :: Int) (Internal.liftInner (sourceUnfoldrM value n))++-------------------------------------------------------------------------------+-- Concurrent application/fold+-------------------------------------------------------------------------------++{-# INLINE parAppMap #-}+parAppMap :: S.MonadAsync m => Stream m Int -> m ()+parAppMap src = S.drain $ S.map (+1) S.|$ src++{-# INLINE parAppSum #-}+parAppSum :: S.MonadAsync m => Stream m Int -> m ()+parAppSum src = (S.sum S.|$. src) >>= \x -> P.seq x (return ())++-------------------------------------------------------------------------------+-- Type class instances+-------------------------------------------------------------------------------++{-# INLINE eqInstance #-}+eqInstance :: Stream Identity Int -> Bool+eqInstance src = src == src++{-# INLINE eqInstanceNotEq #-}+eqInstanceNotEq :: Stream Identity Int -> Bool+eqInstanceNotEq src = src P./= src++{-# INLINE ordInstance #-}+ordInstance :: Stream Identity Int -> Bool+ordInstance src = src P.< src++{-# INLINE ordInstanceMin #-}+ordInstanceMin :: Stream Identity Int -> Stream Identity Int+ordInstanceMin src = P.min src src++{-# INLINE showInstance #-}+showInstance :: Stream Identity Int -> P.String+showInstance src = P.show src++{-# INLINE showInstanceList #-}+showInstanceList :: [Int] -> P.String+showInstanceList src = P.show src++{-# INLINE readInstance #-}+readInstance :: P.String -> Stream Identity Int+readInstance str =+ let r = P.reads str+ in case r of+ [(x,"")] -> x+ _ -> P.error "readInstance: no parse"++{-# INLINE readInstanceList #-}+readInstanceList :: P.String -> [Int]+readInstanceList str =+ let r = P.reads str+ in case r of+ [(x,"")] -> x+ _ -> P.error "readInstance: no parse"++-------------------------------------------------------------------------------+-- Pure (Identity) streams+-------------------------------------------------------------------------------++{-# INLINE pureFoldl' #-}+pureFoldl' :: Stream Identity Int -> Int+pureFoldl' = runIdentity . S.foldl' (+) 0++-------------------------------------------------------------------------------+-- Foldable Instance+-------------------------------------------------------------------------------++{-# INLINE foldableFoldl' #-}+foldableFoldl' :: Int -> Int -> Int+foldableFoldl' value n =+ F.foldl' (+) 0 (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableFoldrElem #-}+foldableFoldrElem :: Int -> Int -> Bool+foldableFoldrElem value n =+ F.foldr (\x xs -> if x == value then P.True else xs)+ (P.False)+ (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableSum #-}+foldableSum :: Int -> Int -> Int+foldableSum value n =+ P.sum (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableProduct #-}+foldableProduct :: Int -> Int -> Int+foldableProduct value n =+ P.product (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE _foldableNull #-}+_foldableNull :: Int -> Int -> Bool+_foldableNull value n =+ P.null (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableElem #-}+foldableElem :: Int -> Int -> Bool+foldableElem value n =+ P.elem value (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableNotElem #-}+foldableNotElem :: Int -> Int -> Bool+foldableNotElem value n =+ P.notElem value (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableFind #-}+foldableFind :: Int -> Int -> Maybe Int+foldableFind value n =+ F.find (== (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableAll #-}+foldableAll :: Int -> Int -> Bool+foldableAll value n =+ P.all (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableAny #-}+foldableAny :: Int -> Int -> Bool+foldableAny value n =+ P.any (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableAnd #-}+foldableAnd :: Int -> Int -> Bool+foldableAnd value n =+ P.and $ S.map (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableOr #-}+foldableOr :: Int -> Int -> Bool+foldableOr value n =+ P.or $ S.map (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableLength #-}+foldableLength :: Int -> Int -> Int+foldableLength value n =+ P.length (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableMin #-}+foldableMin :: Int -> Int -> Int+foldableMin value n =+ P.minimum (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableMax #-}+foldableMax :: Int -> Int -> Int+foldableMax value n =+ P.maximum (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableMinBy #-}+foldableMinBy :: Int -> Int -> Int+foldableMinBy value n =+ F.minimumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableListMinBy #-}+foldableListMinBy :: Int -> Int -> Int+foldableListMinBy value n = F.minimumBy compare [1..value+n]++{-# INLINE foldableMaxBy #-}+foldableMaxBy :: Int -> Int -> Int+foldableMaxBy value n =+ F.maximumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableToList #-}+foldableToList :: Int -> Int -> [Int]+foldableToList value n =+ F.toList (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableMapM_ #-}+foldableMapM_ :: Monad m => Int -> Int -> m ()+foldableMapM_ value n =+ F.mapM_ (\_ -> return ()) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableSequence_ #-}+foldableSequence_ :: Int -> Int -> IO ()+foldableSequence_ value n =+ F.sequence_ (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))++{-# INLINE _foldableMsum #-}+_foldableMsum :: Int -> Int -> IO Int+_foldableMsum value n =+ F.msum (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))++-------------------------------------------------------------------------------+-- Traversable Instance+-------------------------------------------------------------------------------++{-# INLINE traversableTraverse #-}+traversableTraverse :: Stream Identity Int -> IO (Stream Identity Int)+traversableTraverse = P.traverse return++{-# INLINE traversableSequenceA #-}+traversableSequenceA :: Stream Identity Int -> IO (Stream Identity Int)+traversableSequenceA = P.sequenceA . P.fmap return++{-# INLINE traversableMapM #-}+traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)+traversableMapM = P.mapM return++{-# INLINE traversableSequence #-}+traversableSequence :: Stream Identity Int -> IO (Stream Identity Int)+traversableSequence = P.sequence . P.fmap return++-------------------------------------------------------------------------------+-- Benchmark groups+-------------------------------------------------------------------------------++-- We need a monadic bind here to make sure that the function f does not get+-- completely optimized out by the compiler in some cases.++-- | Takes a fold method, and uses it with a default source.+{-# INLINE benchIOSink #-}+benchIOSink+ :: (IsStream t, NFData b)+ => Int -> String -> (t IO Int -> IO b) -> Benchmark+benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . source value++{-# INLINE benchHoistSink #-}+benchHoistSink+ :: (IsStream t, NFData b)+ => Int -> String -> (t Identity Int -> IO b) -> Benchmark+benchHoistSink value name f =+ bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldr value++-- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but+-- we can't use it as it requires MonadAsync constraint.+{-# INLINE benchIdentitySink #-}+benchIdentitySink+ :: (IsStream t, NFData b)+ => Int -> String -> (t Identity Int -> Identity b) -> Benchmark+benchIdentitySink value name f = bench name $ nf (f . sourceUnfoldr value) 1++-- | Takes a source, and uses it with a default drain/fold method.+{-# INLINE benchIOSrc #-}+benchIOSrc+ :: (t IO a -> SerialT IO a)+ -> String+ -> (Int -> t IO a)+ -> Benchmark+benchIOSrc t name f =+ bench name $ nfIO $ randomRIO (1,1) >>= toNull t . f++{-# INLINE benchPureSink #-}+benchPureSink :: NFData b => Int -> String -> (SerialT Identity Int -> b) -> Benchmark+benchPureSink value name f = benchPure name (sourceUnfoldr value) f++{-# INLINE benchPureSinkIO #-}+benchPureSinkIO+ :: NFData b+ => Int -> String -> (SerialT Identity Int -> IO b) -> Benchmark+benchPureSinkIO value name f =+ bench name $ nfIO $ randomRIO (1, 1) >>= f . sourceUnfoldr value++{-# INLINE benchIO #-}+benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark+benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f++-- | Takes a source, and uses it with a default drain/fold method.+{-# INLINE benchSrcIO #-}+benchSrcIO+ :: (t IO a -> SerialT IO a)+ -> String+ -> (Int -> t IO a)+ -> Benchmark+benchSrcIO t name f+ = bench name $ nfIO $ randomRIO (1,1) >>= toNull t . f++{-# INLINE benchMonadicSrcIO #-}+benchMonadicSrcIO :: String -> (Int -> IO ()) -> Benchmark+benchMonadicSrcIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f+++-------------------------------------------------------------------------------+-- Serial : O(1) Space+-------------------------------------------------------------------------------++o_1_space_serial_pure :: Int -> [Benchmark]+o_1_space_serial_pure value =+ [ bgroup+ "serially"+ [ bgroup+ "pure"+ [ benchPureSink value "id" P.id+ , benchPureSink1 "eqBy" (eqByPure value)+ , benchPureSink value "==" eqInstance+ , benchPureSink value "/=" eqInstanceNotEq+ , benchPureSink1 "cmpBy" (cmpByPure value)+ , benchPureSink value "<" ordInstance+ , benchPureSink value "min" ordInstanceMin+ , benchPureSrc "IsList.fromList" (sourceIsList value)+ -- length is used to check for foldr/build fusion+ , benchPureSink+ value+ "length . IsList.toList"+ (P.length . GHC.toList)+ , benchPureSrc "IsString.fromString" (sourceIsString value)+ , benchPureSink value "showsPrec pure streams" showInstance+ , benchPureSink value "foldl'" pureFoldl'+ ]+ ]+ ]++o_1_space_serial_foldable :: Int -> [Benchmark]+o_1_space_serial_foldable value =+ [ bgroup+ "serially"+ [ bgroup+ "foldable"+ -- Foldable instance+ -- type class operations+ [ bench "foldl'" $ nf (foldableFoldl' value) 1+ , bench "foldrElem" $ nf (foldableFoldrElem value) 1+ -- , bench "null" $ nf (_foldableNull value) 1+ , bench "elem" $ nf (foldableElem value) 1+ , bench "length" $ nf (foldableLength value) 1+ , bench "sum" $ nf (foldableSum value) 1+ , bench "product" $ nf (foldableProduct value) 1+ , bench "minimum" $ nf (foldableMin value) 1+ , bench "maximum" $ nf (foldableMax value) 1+ , bench "length . toList" $+ nf (P.length . foldableToList value) 1+ -- folds+ , bench "notElem" $ nf (foldableNotElem value) 1+ , bench "find" $ nf (foldableFind value) 1+ , bench "all" $ nf (foldableAll value) 1+ , bench "any" $ nf (foldableAny value) 1+ , bench "and" $ nf (foldableAnd value) 1+ , bench "or" $ nf (foldableOr value) 1+ -- Note: minimumBy/maximumBy do not work in constant memory they are in+ -- the O(n) group of benchmarks down below in this file.+ -- Applicative and Traversable operations+ -- TBD: traverse_+ , benchIOSink1 "mapM_" (foldableMapM_ value)+ -- TBD: for_+ -- TBD: forM_+ , benchIOSink1 "sequence_" (foldableSequence_ value)+ -- TBD: sequenceA_+ -- TBD: asum+ -- , benchIOSink1 "msum" (_foldableMsum value)+ ]+ ]+ ]++o_1_space_serial_generation :: Int -> [Benchmark]+o_1_space_serial_generation value =+ [ bgroup+ "serially"+ [ bgroup+ "generation"+ -- Most basic, barely stream continuations running+ [ benchIOSrc serially "unfoldr" (sourceUnfoldr value)+ , benchIOSrc serially "unfoldrM" (sourceUnfoldrM value)+ , benchIOSrc serially "intFromTo" (sourceIntFromTo value)+ , benchIOSrc+ serially+ "intFromThenTo"+ (sourceIntFromThenTo value)+ , benchIOSrc+ serially+ "integerFromStep"+ (sourceIntegerFromStep value)+ , benchIOSrc+ serially+ "fracFromThenTo"+ (sourceFracFromThenTo value)+ , benchIOSrc serially "fracFromTo" (sourceFracFromTo value)+ , benchIOSrc serially "fromList" (sourceFromList value)+ , benchIOSrc serially "fromListM" (sourceFromListM value)+ -- These are essentially cons and consM+ , benchIOSrc+ serially+ "fromFoldable"+ (sourceFromFoldable value)+ , benchIOSrc+ serially+ "fromFoldableM"+ (sourceFromFoldableM value)+ , benchIOSrc serially "currentTime/0.00001s" $+ currentTime value 0.00001+ ]+ ]+ ]++o_1_space_serial_elimination :: Int -> [Benchmark]+o_1_space_serial_elimination value =+ [ bgroup+ "serially"+ [ bgroup+ "elimination"+ [ bgroup+ "reduce"+ [ bgroup+ "IO"+ [ benchIOSink value "foldl'" foldl'Reduce+ , benchIOSink value "foldl1'" foldl1'Reduce+ , benchIOSink value "foldlM'" foldlM'Reduce+ ]+ , bgroup+ "Identity"+ [ benchIdentitySink value "foldl'" foldl'Reduce+ , benchIdentitySink+ value+ "foldl1'"+ foldl1'Reduce+ , benchIdentitySink+ value+ "foldlM'"+ foldlM'Reduce+ ]+ ]+ , bgroup+ "build"+ [ bgroup+ "IO"+ [ benchIOSink+ value+ "foldrMElem"+ (foldrMElem value)+ ]+ , bgroup+ "Identity"+ [ benchIdentitySink+ value+ "foldrMElem"+ (foldrMElem value)+ , benchIdentitySink+ value+ "foldrMToStreamLength"+ (S.length . runIdentity . foldrMToStream)+ , benchPureSink+ value+ "foldrMToListLength"+ (P.length . runIdentity . foldrMBuild)+ ]+ ]+ , benchIOSink value "uncons" uncons+ , benchIOSink value "toNull" $ toNull serially+ , benchIOSink value "mapM_" mapM_+ , benchIOSink value "init" init+ -- this is too low and causes all benchmarks reported in ns+ -- , benchIOSink value "head" head+ , benchIOSink value "last" last+ -- , benchIOSink value "lookup" lookup+ , benchIOSink value "find" (find value)+ , benchIOSink value "findIndex" (findIndex value)+ , benchIOSink value "elemIndex" (elemIndex value)+ -- this is too low and causes all benchmarks reported in ns+ -- , benchIOSink value "null" null+ , benchIOSink value "elem" (elem value)+ , benchIOSink value "notElem" (notElem value)+ , benchIOSink value "all" (all value)+ , benchIOSink value "any" (any value)+ , benchIOSink value "and" (and value)+ , benchIOSink value "or" (or value)+ , benchIOSink value "length" length+ , benchHoistSink+ value+ "length . generally"+ (length . IP.generally)+ , benchIOSink value "sum" sum+ , benchIOSink value "product" product+ , benchIOSink value "maximumBy" maximumBy+ , benchIOSink value "maximum" maximum+ , benchIOSink value "minimumBy" minimumBy+ , benchIOSink value "minimum" minimum+ ]+ ]+ ]++o_1_space_serial_foldMultiStream :: Int -> [Benchmark]+o_1_space_serial_foldMultiStream value =+ [ bgroup+ "serially"+ [ bgroup+ "fold-multi-stream"+ [ benchIOSink1 "eqBy" (eqBy value)+ , benchIOSink1 "cmpBy" (cmpBy value)+ , benchIOSink value "isPrefixOf" isPrefixOf+ , benchIOSink value "isSubsequenceOf" isSubsequenceOf+ , benchIOSink value "stripPrefix" stripPrefix+ ]+ ]+ ]++o_1_space_serial_pipes :: Int -> [Benchmark]+o_1_space_serial_pipes value =+ [ bgroup+ "serially"+ [ bgroup+ "pipes"+ [ benchIOSink value "mapM" (transformMapM serially 1)+ , benchIOSink+ value+ "compose"+ (transformComposeMapM serially 1)+ , benchIOSink value "tee" (transformTeeMapM serially 1)+ , benchIOSink value "zip" (transformZipMapM serially 1)+ ]+ ]+ ]++o_1_space_serial_pipesX4 :: Int -> [Benchmark]+o_1_space_serial_pipesX4 value =+ [ bgroup+ "serially"+ [ bgroup+ "pipesX4"+ [ benchIOSink value "mapM" (transformMapM serially 4)+ , benchIOSink+ value+ "compose"+ (transformComposeMapM serially 4)+ , benchIOSink value "tee" (transformTeeMapM serially 4)+ , benchIOSink value "zip" (transformZipMapM serially 4)+ ]+ ]+ ]+++o_1_space_serial_transformer :: Int -> [Benchmark]+o_1_space_serial_transformer value =+ [ bgroup+ "serially"+ [ bgroup+ "transformer"+ [ benchIOSrc serially "evalState" (evalStateT value)+ , benchIOSrc serially "withState" (withState value)+ ]+ ]+ ]++o_1_space_serial_transformation :: Int -> [Benchmark]+o_1_space_serial_transformation value =+ [ bgroup+ "serially"+ [ bgroup+ "transformation"+ [ benchIOSink value "scanl" (scan 1)+ , benchIOSink value "scanl1'" (scanl1' 1)+ , benchIOSink value "map" (map 1)+ , benchIOSink value "fmap" (fmap 1)+ , benchIOSink value "mapM" (mapM serially 1)+ , benchIOSink value "mapMaybe" (mapMaybe 1)+ , benchIOSink value "mapMaybeM" (mapMaybeM 1)+ , bench "sequence" $+ nfIO $+ randomRIO (1, 1000) >>= \n ->+ sequence serially (sourceUnfoldrMAction value n)+ , benchIOSink value "findIndices" (findIndices value 1)+ , benchIOSink value "elemIndices" (elemIndices value 1)+ , benchIOSink value "foldrS" (foldrS 1)+ , benchIOSink value "foldrSMap" (foldrSMap 1)+ , benchIOSink value "foldrT" (foldrT 1)+ , benchIOSink value "foldrTMap" (foldrTMap 1)+ , benchIOSink value "tap" (tap 1)+ , benchIOSink value "tapRate 1 second" (tapRate 1)+ , benchIOSink value "pollCounts 1 second" (pollCounts 1)+ , benchIOSink value "tapAsync" (tapAsync 1)+ , benchIOSink value "tapAsyncS" (tapAsyncS 1)+ ]+ ]+ ]++o_1_space_serial_transformationX4 :: Int -> [Benchmark]+o_1_space_serial_transformationX4 value =+ [ bgroup+ "serially"+ [ bgroup+ "transformationX4"+ [ benchIOSink value "scan" (scan 4)+ , benchIOSink value "scanl1'" (scanl1' 4)+ , benchIOSink value "map" (map 4)+ , benchIOSink value "fmap" (fmap 4)+ , benchIOSink value "mapM" (mapM serially 4)+ , benchIOSink value "mapMaybe" (mapMaybe 4)+ , benchIOSink value "mapMaybeM" (mapMaybeM 4)+ -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->+ -- sequence serially (sourceUnfoldrMAction n)+ , benchIOSink value "findIndices" (findIndices value 4)+ , benchIOSink value "elemIndices" (elemIndices value 4)+ ]+ ]+ ]++o_1_space_serial_filtering :: Int -> [Benchmark]+o_1_space_serial_filtering value =+ [ bgroup+ "serially"+ [ bgroup+ "filtering"+ [ benchIOSink value "filter-even" (filterEven 1)+ , benchIOSink value "filter-all-out" (filterAllOut value 1)+ , benchIOSink value "filter-all-in" (filterAllIn value 1)+ , benchIOSink value "take-all" (takeAll value 1)+ , benchIOSink+ value+ "takeByTime-all"+ (takeByTime (NanoSecond64 maxBound) 1)+ , benchIOSink value "takeWhile-true" (takeWhileTrue value 1)+ --, benchIOSink value "takeWhileM-true" (_takeWhileMTrue 1)+ -- "drop-one" is dual to "last"+ , benchIOSink value "drop-one" (dropOne 1)+ , benchIOSink value "drop-all" (dropAll value 1)+ , benchIOSink+ value+ "dropByTime-all"+ (dropByTime (NanoSecond64 maxBound) 1)+ , benchIOSink value "dropWhile-true" (dropWhileTrue value 1)+ --, benchIOSink value "dropWhileM-true" (_dropWhileMTrue 1)+ , benchIOSink+ value+ "dropWhile-false"+ (dropWhileFalse value 1)+ , benchIOSink value "deleteBy" (deleteBy value 1)+ , benchIOSink value "intersperse" (intersperse value 1)+ , benchIOSink value "insertBy" (insertBy value 1)+ ]+ ]+ ]++o_1_space_serial_filteringX4 :: Int -> [Benchmark]+o_1_space_serial_filteringX4 value =+ [ bgroup+ "serially"+ [ bgroup+ "filteringX4"+ [ benchIOSink value "filter-even" (filterEven 4)+ , benchIOSink value "filter-all-out" (filterAllOut value 4)+ , benchIOSink value "filter-all-in" (filterAllIn value 4)+ , benchIOSink value "take-all" (takeAll value 4)+ , benchIOSink value "takeWhile-true" (takeWhileTrue value 4)+ --, benchIOSink value "takeWhileM-true" (_takeWhileMTrue 4)+ , benchIOSink value "drop-one" (dropOne 4)+ , benchIOSink value "drop-all" (dropAll value 4)+ , benchIOSink value "dropWhile-true" (dropWhileTrue value 4)+ --, benchIOSink value "dropWhileM-true" (_dropWhileMTrue 4)+ , benchIOSink+ value+ "dropWhile-false"+ (dropWhileFalse value 4)+ , benchIOSink value "deleteBy" (deleteBy value 4)+ , benchIOSink value "intersperse" (intersperse value 4)+ , benchIOSink value "insertBy" (insertBy value 4)+ ]+ ]+ ]++o_1_space_serial_joining :: Int -> [Benchmark]+o_1_space_serial_joining value =+ [ bgroup+ "serially"+ [ bgroup+ "joining"+ [ benchIOSrc1 "zip (2,x/2)" (zip (value `div` 2))+ , benchIOSrc1 "zipM (2,x/2)" (zipM (value `div` 2))+ , benchIOSrc1 "mergeBy (2,x/2)" (mergeBy (value `div` 2))+ , benchIOSrc1 "serial (2,x/2)" (serial2 (value `div` 2))+ , benchIOSrc1 "append (2,x/2)" (append2 (value `div` 2))+ , benchIOSrc1 "serial (2,2,x/4)" (serial4 (value `div` 4))+ , benchIOSrc1 "append (2,2,x/4)" (append4 (value `div` 4))+ , benchIOSrc1 "wSerial (2,x/2)" (wSerial2 value) -- XXX Move this elsewhere?+ , benchIOSrc1 "interleave (2,x/2)" (interleave2 value)+ , benchIOSrc1 "roundRobin (2,x/2)" (roundRobin2 value)+ ]+ ]+ ]++o_1_space_serial_concatFoldable :: Int -> [Benchmark]+o_1_space_serial_concatFoldable value =+ [ bgroup+ "serially"+ [ bgroup+ "concat-foldable"+ [ benchIOSrc+ serially+ "foldMapWith"+ (sourceFoldMapWith value)+ , benchIOSrc+ serially+ "foldMapWithM"+ (sourceFoldMapWithM value)+ , benchIOSrc serially "foldMapM" (sourceFoldMapM value)+ , benchIOSrc+ serially+ "foldWithConcatMapId"+ (sourceConcatMapId value)+ ]+ ]+ ]++o_1_space_serial_concatSerial :: Int -> [Benchmark]+o_1_space_serial_concatSerial value =+ [ bgroup+ "serially"+ [ bgroup+ "concat-serial"+ [ benchIOSrc1+ "concatMapPure (2,x/2)"+ (concatMapPure 2 (value `div` 2))+ , benchIOSrc1+ "concatMap (2,x/2)"+ (concatMap 2 (value `div` 2))+ , benchIOSrc1+ "concatMap (x/2,2)"+ (concatMap (value `div` 2) 2)+ , benchIOSrc1+ "concatMapRepl (x/4,4)"+ (concatMapRepl4xN value)+ , benchIOSrc1+ "concatUnfoldRepl (x/4,4)"+ (concatUnfoldRepl4xN value)+ , benchIOSrc1+ "concatMapWithSerial (2,x/2)"+ (concatMapWithSerial 2 (value `div` 2))+ , benchIOSrc1+ "concatMapWithSerial (x/2,2)"+ (concatMapWithSerial (value `div` 2) 2)+ , benchIOSrc1+ "concatMapWithAppend (2,x/2)"+ (concatMapWithAppend 2 (value `div` 2))+ ]+ ]+ ]++o_1_space_serial_outerProductStreams :: Int -> [Benchmark]+o_1_space_serial_outerProductStreams value =+ [ bgroup+ "serially"+ [ bgroup+ "outer-product-streams"+ [ benchIO "toNullAp" $ Nested.toNullAp value serially+ , benchIO "toNull" $ Nested.toNull value serially+ , benchIO "toNull3" $ Nested.toNull3 value serially+ , benchIO "filterAllOut" $ Nested.filterAllOut value serially+ , benchIO "filterAllIn" $ Nested.filterAllIn value serially+ , benchIO "filterSome" $ Nested.filterSome value serially+ , benchIO "breakAfterSome" $+ Nested.breakAfterSome value serially+ ]+ ]+ ]++o_1_space_serial_mixed :: Int -> [Benchmark]+o_1_space_serial_mixed value =+ [ bgroup+ "serially"+ -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl+ -- library. If scan/fold followed by a map is efficient enough we may not+ -- need monolithic implementations of these.+ [ bgroup+ "mixed"+ [ benchIOSink value "scanl-map" (scanMap 1)+ , benchIOSink value "foldl-map" foldl'ReduceMap+ , benchIOSink value "sum-product-fold" sumProductFold+ , benchIOSink value "sum-product-scan" sumProductScan+ ]+ ]+ ]++o_1_space_serial_mixedX4 :: Int -> [Benchmark]+o_1_space_serial_mixedX4 value =+ [ bgroup+ "serially"+ [ bgroup+ "mixedX4"+ [ benchIOSink value "scan-map" (scanMap 4)+ , benchIOSink value "drop-map" (dropMap 4)+ , benchIOSink value "drop-scan" (dropScan 4)+ , benchIOSink value "take-drop" (takeDrop value 4)+ , benchIOSink value "take-scan" (takeScan value 4)+ , benchIOSink value "take-map" (takeMap value 4)+ , benchIOSink value "filter-drop" (filterDrop value 4)+ , benchIOSink value "filter-take" (filterTake value 4)+ , benchIOSink value "filter-scan" (filterScan 4)+ , benchIOSink value "filter-scanl1" (filterScanl1 4)+ , benchIOSink value "filter-map" (filterMap value 4)+ ]+ ]+ ]++o_1_space_wSerial_transformation :: Int -> [Benchmark]+o_1_space_wSerial_transformation value =+ [ bgroup+ "wSerially"+ [ bgroup+ "transformation"+ [benchIOSink value "fmap" $ fmap' wSerially 1]+ ]+ ]++o_1_space_wSerial_concatMap :: Int -> [Benchmark]+o_1_space_wSerial_concatMap value =+ [ bgroup+ "wSerially"+ [ bgroup+ "concatMap"+ [ benchIOSrc1+ "concatMapWithWSerial (2,x/2)"+ (concatMapWithWSerial 2 (value `div` 2))+ , benchIOSrc1+ "concatMapWithWSerial (x/2,2)"+ (concatMapWithWSerial (value `div` 2) 2)+ ]+ ]+ ]++o_1_space_wSerial_outerProduct :: Int -> [Benchmark]+o_1_space_wSerial_outerProduct value =+ [ bgroup+ "wSerially"+ [ bgroup+ "outer-product"+ [ benchIO "toNullAp" $ Nested.toNullAp value wSerially+ , benchIO "toNull" $ Nested.toNull value wSerially+ , benchIO "toNull3" $ Nested.toNull3 value wSerially+ , benchIO "filterAllOut" $ Nested.filterAllOut value wSerially+ , benchIO "filterAllIn" $ Nested.filterAllIn value wSerially+ , benchIO "filterSome" $ Nested.filterSome value wSerially+ , benchIO "breakAfterSome" $+ Nested.breakAfterSome value wSerially+ ]+ ]+ ]++o_1_space_zipSerial_transformation :: Int -> [Benchmark]+o_1_space_zipSerial_transformation value =+ [ bgroup+ "zipSerially"+ [ bgroup+ "transformation"+ [benchIOSink value "fmap" $ fmap' zipSerially 1]+ -- XXX needs fixing+ {-+ , bgroup "outer-product"+ [ benchIO "toNullAp" $ Nested.toNullAp value zipSerially+ ]+ -}+ ]+ ]++-------------------------------------------------------------------------------+-- Serial : O(n) Space+-------------------------------------------------------------------------------++o_n_space_serial_toList :: Int -> [Benchmark]+o_n_space_serial_toList value =+ [ bgroup+ "serially"+ [ bgroup+ "toList" -- < 2MB+ -- Converting the stream to a list or pure stream in a strict monad+ [ benchIOSink value "foldrMToList" foldrMBuild+ , benchIOSink value "toList" toList+ , benchIOSink value "toListRev" toListRev+ -- , benchIOSink value "toPure" toPure+ -- , benchIOSink value "toPureRev" toPureRev+ ]+ ]+ ]++o_n_space_serial_outerProductStreams :: Int -> [Benchmark]+o_n_space_serial_outerProductStreams value =+ [ bgroup+ "serially"+ [ bgroup+ "outer-product-streams"+ [ benchIO "toList" $ Nested.toList value serially+ , benchIO "toListSome" $ Nested.toListSome value serially+ ]+ ]+ ]++o_n_space_wSerial_outerProductStreams :: Int -> [Benchmark]+o_n_space_wSerial_outerProductStreams value =+ [ bgroup+ "wSerially"+ [ bgroup+ "outer-product-streams"+ [ benchIO "toList" $ Nested.toList value wSerially+ , benchIO "toListSome" $ Nested.toListSome value wSerially+ ]+ ]+ ]++o_n_space_serial_traversable :: Int -> [Benchmark]+o_n_space_serial_traversable value =+ [ bgroup+ "serially"+ -- Buffering operations using heap proportional to number of elements.+ [ bgroup+ "traversable" -- < 2MB+ -- Traversable instance+ [ benchPureSinkIO value "traverse" traversableTraverse+ , benchPureSinkIO value "sequenceA" traversableSequenceA+ , benchPureSinkIO value "mapM" traversableMapM+ , benchPureSinkIO value "sequence" traversableSequence+ ]+ ]+ ]++o_n_space_serial_foldr :: Int -> [Benchmark]+o_n_space_serial_foldr value =+ [ bgroup+ "serially"+ -- Head recursive strict right folds.+ [ bgroup+ "foldr"+ -- < 2MB+ -- accumulation due to strictness of IO monad+ [ benchIOSink value "foldrM/build/IO" foldrMBuild+ -- Right folds for reducing are inherently non-streaming as the+ -- expression needs to be fully built before it can be reduced.+ , benchIdentitySink+ value+ "foldrM/reduce/Identity"+ foldrMReduce+ -- takes < 4MB+ , benchIOSink value "foldrM/reduce/IO" foldrMReduce+ -- XXX the definitions of minimumBy and maximumBy in Data.Foldable use+ -- foldl1 which does not work in constant memory for our implementation.+ -- It works in constant memory for lists but even for lists it takes 15x+ -- more time compared to our foldl' based implementation.+ -- XXX these take < 16M stack space+ , bench "minimumBy" $ nf (flip foldableMinBy 1) value+ , bench "maximumBy" $ nf (flip foldableMaxBy 1) value+ , bench "minimumByList" $ nf (flip foldableListMinBy 1) value+ ]+ ]+ ]+++o_n_heap_serial_foldl :: Int -> [Benchmark]+o_n_heap_serial_foldl value =+ [ bgroup+ "serially"+ [ bgroup+ "foldl"+ -- Left folds for building a structure are inherently non-streaming+ -- as the structure cannot be lazily consumed until fully built.+ [ benchIOSink value "foldl'/build/IO" foldl'Build+ , benchIdentitySink value "foldl'/build/Identity" foldl'Build+ , benchIOSink value "foldlM'/build/IO" foldlM'Build+ , benchIdentitySink+ value+ "foldlM'/build/Identity"+ foldlM'Build+ -- Reversing/sorting a stream+ , benchIOSink value "reverse" (reverse 1)+ , benchIOSink value "reverse'" (reverse' 1)+ ]+ ]+ ]++o_n_heap_serial_buffering :: Int -> [Benchmark]+o_n_heap_serial_buffering value =+ [ bgroup+ "serially"+ [ bgroup+ "buffering"+ -- Buffers the output of show/read.+ -- XXX can the outputs be streaming? Can we have special read/show+ -- style type classes, readM/showM supporting streaming effects?+ [ bench "readsPrec pure streams" $+ nf readInstance (mkString value)+ , bench "readsPrec Haskell lists" $+ nf readInstanceList (mkListString value)+ , bench "showPrec Haskell lists" $+ nf showInstanceList (mkList value)+ -- interleave x/4 streams of 4 elements each. Needs to buffer+ -- proportional to x/4. This is different from WSerial because+ -- WSerial expands slowly because of binary interleave behavior and+ -- this expands immediately because of Nary interleave behavior.+ , benchIOSrc1+ "concatUnfoldInterleaveRepl (x/4,4)"+ (concatUnfoldInterleaveRepl4xN value)+ , benchIOSrc1+ "concatUnfoldRoundrobinRepl (x/4,4)"+ (concatUnfoldRoundrobinRepl4xN value)+ ]+ ]+ ]++-- Head recursive operations.+o_n_stack_serial_iterated :: Int -> [Benchmark]+o_n_stack_serial_iterated value =+ [ bgroup+ "serially"+ [ bgroup+ "iterated"+ [ benchIOSrc serially "mapMx10K" iterateMapM+ , benchIOSrc serially "scanx100" iterateScan+ , benchIOSrc serially "scanl1x100" iterateScanl1+ , benchIOSrc serially "filterEvenx10K" iterateFilterEven+ , benchIOSrc serially "takeAllx10K" (iterateTakeAll value)+ , benchIOSrc serially "dropOnex10K" iterateDropOne+ , benchIOSrc+ serially+ "dropWhileFalsex10K"+ (iterateDropWhileFalse value)+ , benchIOSrc+ serially+ "dropWhileTruex10K"+ (iterateDropWhileTrue value)+ , benchIOSink value "tail" tail+ , benchIOSink value "nullHeadTail" nullHeadTail+ ]+ ]+ ]++o_1_space_async_generation :: Int -> [Benchmark]+o_1_space_async_generation value =+ [ bgroup+ "asyncly"+ [ bgroup+ "generation"+ [ benchSrcIO asyncly "unfoldr" (sourceUnfoldr value)+ , benchSrcIO asyncly "unfoldrM" (sourceUnfoldrM value)+ , benchSrcIO asyncly "fromFoldable" (sourceFromFoldable value)+ , benchSrcIO asyncly "fromFoldableM" (sourceFromFoldableM value)+ , benchSrcIO+ asyncly+ "unfoldrM maxThreads 1"+ (maxThreads 1 . sourceUnfoldrM value)+ , benchSrcIO+ asyncly+ "unfoldrM maxBuffer 1 (x/10 ops)"+ (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))+ ]+ ]+ ]++o_1_space_async_concatFoldable :: Int -> [Benchmark]+o_1_space_async_concatFoldable value =+ [ bgroup+ "asyncly"+ [ bgroup+ "concat-foldable"+ [ benchSrcIO asyncly "foldMapWith" (sourceFoldMapWith value)+ , benchSrcIO+ asyncly+ "foldMapWithM"+ (sourceFoldMapWithM value)+ , benchSrcIO asyncly "foldMapM" (sourceFoldMapM value)+ ]+ ]+ ]++o_1_space_async_concatMap :: Int -> [Benchmark]+o_1_space_async_concatMap value =+ value2 `seq`+ [ bgroup+ "asyncly"+ [ bgroup+ "concatMap"+ [ benchMonadicSrcIO+ "concatMapWith (2,x/2)"+ (concatStreamsWith async 2 (value `div` 2))+ , benchMonadicSrcIO+ "concatMapWith (sqrt x,sqrt x)"+ (concatStreamsWith async value2 value2)+ , benchMonadicSrcIO+ "concatMapWith (sqrt x * 2,sqrt x / 2)"+ (concatStreamsWith async (value2 * 2) (value2 `div` 2))+ ]+ ]+ ]+ where+ value2 = round $ sqrt $ (fromIntegral value :: Double)++o_1_space_async_transformation :: Int -> [Benchmark]+o_1_space_async_transformation value =+ [ bgroup+ "asyncly"+ [ bgroup+ "transformation"+ [ benchIOSink value "map" $ map' asyncly 1+ , benchIOSink value "fmap" $ fmap' asyncly 1+ , benchIOSink value "mapM" $ mapM asyncly 1+ ]+ ]+ ]++o_1_space_wAsync_generation :: Int -> [Benchmark]+o_1_space_wAsync_generation value =+ [ bgroup+ "wAsyncly"+ [ bgroup+ "generation"+ [ benchSrcIO wAsyncly "unfoldr" (sourceUnfoldr value)+ , benchSrcIO wAsyncly "unfoldrM" (sourceUnfoldrM value)+ , benchSrcIO wAsyncly "fromFoldable" (sourceFromFoldable value)+ , benchSrcIO+ wAsyncly+ "fromFoldableM"+ (sourceFromFoldableM value)+ , benchSrcIO+ wAsyncly+ "unfoldrM maxThreads 1"+ (maxThreads 1 . sourceUnfoldrM value)+ , benchSrcIO+ wAsyncly+ "unfoldrM maxBuffer 1 (x/10 ops)"+ (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))+ ]+ ]+ ]++o_1_space_wAsync_concatFoldable :: Int -> [Benchmark]+o_1_space_wAsync_concatFoldable value =+ [ bgroup+ "wAsyncly"+ [ bgroup+ "concat-foldable"+ [ benchSrcIO wAsyncly "foldMapWith" (sourceFoldMapWith value)+ , benchSrcIO wAsyncly "foldMapWithM" (sourceFoldMapWithM value)+ , benchSrcIO wAsyncly "foldMapM" (sourceFoldMapM value)+ ]+ ]+ ]++-- When we merge streams using wAsync the size of the queue increases+-- slowly because of the binary composition adding just one more item+-- to the work queue only after every scheduling pass through the+-- work queue.+--+-- We should see the memory consumption increasing slowly if these+-- benchmarks are left to run on infinite number of streams of infinite+-- sizes.+o_1_space_wAsync_concatMap :: Int -> [Benchmark]+o_1_space_wAsync_concatMap value =+ value2 `seq`+ [ bgroup+ "wAsyncly"+ [ benchMonadicSrcIO+ "concatMapWith (2,x/2)"+ (concatStreamsWith wAsync 2 (value `div` 2))+ , benchMonadicSrcIO+ "concatMapWith (sqrt x,sqrt x)"+ (concatStreamsWith wAsync value2 value2)+ , benchMonadicSrcIO+ "concatMapWith (sqrt x * 2,sqrt x / 2)"+ (concatStreamsWith wAsync (value2 * 2) (value2 `div` 2))+ ]+ ]+ where+ value2 = round $ sqrt $ (fromIntegral value :: Double)++o_1_space_wAsync_transformation :: Int -> [Benchmark]+o_1_space_wAsync_transformation value =+ [ bgroup+ "wAsyncly"+ [ bgroup+ "transformation"+ [ benchIOSink value "map" $ map' wAsyncly 1+ , benchIOSink value "fmap" $ fmap' wAsyncly 1+ , benchIOSink value "mapM" $ mapM wAsyncly 1+ ]+ ]+ ]++-- unfoldr and fromFoldable are always serial and therefore the same for+-- all stream types. They can be removed to reduce the number of benchmarks.+o_1_space_ahead_generation :: Int -> [Benchmark]+o_1_space_ahead_generation value =+ [ bgroup+ "aheadly"+ [ bgroup+ "generation"+ [ benchSrcIO aheadly "unfoldr" (sourceUnfoldr value)+ , benchSrcIO aheadly "unfoldrM" (sourceUnfoldrM value)+-- , benchSrcIO aheadly "fromFoldable" (sourceFromFoldable value)+ , benchSrcIO+ aheadly+ "fromFoldableM"+ (sourceFromFoldableM value)+ , benchSrcIO+ aheadly+ "unfoldrM maxThreads 1"+ (maxThreads 1 . sourceUnfoldrM value)+ , benchSrcIO+ aheadly+ "unfoldrM maxBuffer 1 (x/10 ops)"+ (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))+ ]+ ]+ ]++o_1_space_ahead_concatFoldable :: Int -> [Benchmark]+o_1_space_ahead_concatFoldable value =+ [ bgroup+ "aheadly"+ [ bgroup+ "concat-foldable"+ [ benchSrcIO aheadly "foldMapWith" (sourceFoldMapWith value)+ , benchSrcIO aheadly "foldMapWithM" (sourceFoldMapWithM value)+ , benchSrcIO aheadly "foldMapM" (sourceFoldMapM value)+ ]+ ]+ ]++o_1_space_ahead_concatMap :: Int -> [Benchmark]+o_1_space_ahead_concatMap value =+ value2 `seq`+ [ bgroup+ "aheadly"+ [ benchMonadicSrcIO+ "concatMapWith (2,x/2)"+ (concatStreamsWith ahead 2 (value `div` 2))+ , benchMonadicSrcIO+ "concatMapWith (sqrt x,sqrt x)"+ (concatStreamsWith ahead value2 value2)+ , benchMonadicSrcIO+ "concatMapWith (sqrt x * 2,sqrt x / 2)"+ (concatStreamsWith ahead (value2 * 2) (value2 `div` 2))+ ]+ ]+ where+ value2 = round $ sqrt $ (fromIntegral value :: Double)+++o_1_space_ahead_transformation :: Int -> [Benchmark]+o_1_space_ahead_transformation value =+ [ bgroup+ "aheadly"+ [ bgroup+ "transformation"+ [ benchIOSink value "map" $ map' aheadly 1+ , benchIOSink value "fmap" $ fmap' aheadly 1+ , benchIOSink value "mapM" $ mapM aheadly 1+ ]+ ]+ ]++o_1_space_async_zip :: Int -> [Benchmark]+o_1_space_async_zip value =+ [ bgroup+ "asyncly"+ [ bgroup+ "zip"+ [ benchSrcIO+ serially+ "zipAsync (2,x/2)"+ (zipAsync (value `div` 2))+ , benchSrcIO+ serially+ "zipAsyncM (2,x/2)"+ (zipAsyncM (value `div` 2))+ , benchSrcIO+ serially+ "zipAsyncAp (2,x/2)"+ (zipAsyncAp (value `div` 2))+ , benchIOSink value "fmap zipAsyncly" $ fmap' S.zipAsyncly 1+ , benchSrcIO+ serially+ "mergeAsyncBy (2,x/2)"+ (mergeAsyncBy (value `div` 2))+ , benchSrcIO+ serially+ "mergeAsyncByM (2,x/2)"+ (mergeAsyncByM (value `div` 2))+ -- Parallel stages in a pipeline+ , benchIOSink value "parAppMap" parAppMap+ , benchIOSink value "parAppSum" parAppSum+ ]+ ]+ ]++o_1_space_parallel_generation :: Int -> [Benchmark]+o_1_space_parallel_generation value =+ [ bgroup+ "parallely"+ [ bgroup+ "generation"+ [ benchSrcIO parallely "unfoldr" (sourceUnfoldr value)+ , benchSrcIO parallely "unfoldrM" (sourceUnfoldrM value)+-- , benchSrcIO parallely "fromFoldable" (sourceFromFoldable value)+ , benchSrcIO+ parallely+ "fromFoldableM"+ (sourceFromFoldableM value)+ , benchSrcIO+ parallely+ "unfoldrM maxThreads 1"+ (maxThreads 1 . sourceUnfoldrM value)+ , benchSrcIO+ parallely+ "unfoldrM maxBuffer 1 (x/10 ops)"+ (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))+ ]+ ]+ ]++o_1_space_parallel_concatFoldable :: Int -> [Benchmark]+o_1_space_parallel_concatFoldable value =+ [ bgroup+ "parallely"+ [ bgroup+ "concat-foldable"+ [ benchSrcIO parallely "foldMapWith" (sourceFoldMapWith value)+ , benchSrcIO parallely "foldMapWithM" (sourceFoldMapWithM value)+ , benchSrcIO parallely "foldMapM" (sourceFoldMapM value)+ ]+ ]+ ]++o_1_space_parallel_concatMap :: Int -> [Benchmark]+o_1_space_parallel_concatMap value =+ value2 `seq`+ [ bgroup+ "parallely"+ [ benchMonadicSrcIO+ "concatMapWith (2,x/2)"+ (concatStreamsWith parallel 2 (value `div` 2))+ , benchMonadicSrcIO+ "concatMapWith (sqrt x,sqrt x)"+ (concatStreamsWith parallel value2 value2)+ , benchMonadicSrcIO+ "concatMapWith (sqrt x * 2,sqrt x / 2)"+ (concatStreamsWith parallel (value2 * 2) (value2 `div` 2))+ ]+ ]+ where+ value2 = round $ sqrt $ (fromIntegral value :: Double)+++o_1_space_parallel_transformation :: Int -> [Benchmark]+o_1_space_parallel_transformation value =+ [ bgroup+ "parallely"+ [ bgroup+ "transformation"+ [ benchIOSink value "map" $ map' parallely 1+ , benchIOSink value "fmap" $ fmap' parallely 1+ , benchIOSink value "mapM" $ mapM parallely 1+ ]+ ]+ ]++o_1_space_parallel_outerProductStreams :: Int -> [Benchmark]+o_1_space_parallel_outerProductStreams value =+ [ bgroup+ "parallely"+ [ bgroup+ "outer-product-streams"+ [ benchIO "toNullAp" $ Nested.toNullAp value parallely+ , benchIO "toNull" $ Nested.toNull value parallely+ , benchIO "toNull3" $ Nested.toNull3 value parallely+ , benchIO "filterAllOut" $ Nested.filterAllOut value parallely+ , benchIO "filterAllIn" $ Nested.filterAllIn value parallely+ , benchIO "filterSome" $ Nested.filterSome value parallely+ , benchIO "breakAfterSome" $+ Nested.breakAfterSome value parallely+ ]+ ]+ ]++o_n_space_parallel_outerProductStreams :: Int -> [Benchmark]+o_n_space_parallel_outerProductStreams value =+ [ bgroup+ "parallely"+ [ bgroup+ "outer-product-streams"+ [ benchIO "toList" $ Nested.toList value parallely+ , benchIO "toListSome" $ Nested.toListSome value parallely+ ]+ ]+ ]++-- XXX arbitrarily large rate should be the same as rate Nothing+o_1_space_async_avgRate :: Int -> [Benchmark]+o_1_space_async_avgRate value =+ [ bgroup+ "asyncly"+ [ bgroup+ "avgRate"+ -- benchIO "unfoldr" $ toNull asyncly+ -- benchSrcIO asyncly "unfoldrM" (sourceUnfoldrM value)+ [ benchSrcIO+ asyncly+ "unfoldrM/Nothing"+ (S.rate Nothing . sourceUnfoldrM value)+ , benchSrcIO+ asyncly+ "unfoldrM/1,000,000"+ (S.avgRate 1000000 . sourceUnfoldrM value)+ , benchSrcIO+ asyncly+ "unfoldrM/3,000,000"+ (S.avgRate 3000000 . sourceUnfoldrM value)+ , benchSrcIO+ asyncly+ "unfoldrM/10,000,000/maxThreads1"+ (maxThreads 1 .+ S.avgRate 10000000 . sourceUnfoldrM value)+ , benchSrcIO+ asyncly+ "unfoldrM/10,000,000"+ (S.avgRate 10000000 . sourceUnfoldrM value)+ , benchSrcIO+ asyncly+ "unfoldrM/20,000,000"+ (S.avgRate 20000000 . sourceUnfoldrM value)+ ]+ ]+ ]++o_1_space_ahead_avgRate :: Int -> [Benchmark]+o_1_space_ahead_avgRate value =+ [ bgroup+ "aheadly"+ [ bgroup+ "avgRate"+ [ benchSrcIO+ aheadly+ "unfoldrM/1,000,000"+ (S.avgRate 1000000 . sourceUnfoldrM value)+ ]+ ]+ ]
+ benchmark/streamly-benchmarks.cabal view
@@ -0,0 +1,473 @@+cabal-version: 2.2+name: streamly-benchmarks+version: 0.0.0+synopsis: Benchmarks for streamly+description: Benchmarks are separated from the main package because we+ want to have a library for benchmarks to reuse the code across different+ benchmark executables. For example, we have common benchmarking code for+ different types of streams. We need different benchmarking executables+ for serial, async, ahead style streams, therefore, we need to use+ the common code in several benchmarks, just changing the type of+ the stream. It takes a long time to compile this file and it gets+ compiled for each benchmarks once if we do not have a library. Cabal+ does no support internal libraries without per-component builds and+ per-component builds are not supported with Configure, so we are not+ left with any other choice.++flag fusion-plugin+ description: Use fusion plugin for benchmarks and executables+ manual: True+ default: False++flag inspection+ description: Enable inspection testing+ manual: True+ default: False++flag debug+ description: Debug build with asserts enabled+ manual: True+ default: False++flag dev+ description: Development build+ manual: True+ default: False++flag has-llvm+ description: Use llvm backend for better performance+ manual: True+ default: False++flag no-charts+ description: Disable benchmark charts in development build+ manual: True+ default: False++-------------------------------------------------------------------------------+-- Common stanzas+-------------------------------------------------------------------------------++common compile-options+ default-language: Haskell2010++ if flag(dev)+ cpp-options: -DDEVBUILD++ if flag(inspection)+ cpp-options: -DINSPECTION++ ghc-options: -Wall++ if flag(has-llvm)+ ghc-options: -fllvm++ if flag(dev)+ ghc-options: -Wmissed-specialisations+ -Wall-missed-specialisations++ if flag(dev) || flag(debug)+ ghc-options: -fno-ignore-asserts++ if impl(ghc >= 8.0)+ ghc-options: -Wcompat+ -Wunrecognised-warning-flags+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ -Wnoncanonical-monad-instances++common optimization-options+ ghc-options: -O2+ -fdicts-strict+ -fspec-constr-recursive=16+ -fmax-worker-args=16+ if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)+ ghc-options: -fplugin Fusion.Plugin++-- We need optimization options here to optimize internal (non-inlined)+-- versions of functions. Also, we have some benchmarking inspection tests+-- part of the library when built with --benchmarks flag. Thos tests fail+-- if we do not use optimization options here. It was observed that due to+-- -O2 here some concurrent/nested benchmarks improved and others regressed.+-- We can investigate a bit more here why the regression occurred.+common lib-options+ import: compile-options, optimization-options++common bench-depends+ build-depends:+ -- Core libraries shipped with ghc, the min and max+ -- constraints of these libraries should match with+ -- the GHC versions we support+ base >= 4.8 && < 5+ , deepseq >= 1.4.1 && < 1.5+ , mtl >= 2.2 && < 3++ -- other libraries+ , streamly >= 0.7.0+ , random >= 1.0 && < 2.0+ , gauge >= 0.2.4 && < 0.3+ if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)+ build-depends:+ fusion-plugin >= 0.2 && < 0.3+ if impl(ghc < 8.0)+ build-depends:+ transformers >= 0.4 && < 0.6+ if flag(inspection)+ build-depends: template-haskell >= 2.14 && < 2.17+ , inspection-testing >= 0.4 && < 0.5+ -- Array uses a Storable constraint in dev build making several inspection+ -- tests fail+ if flag(dev) && flag(inspection)+ build-depends: inspection-and-dev-flags-cannot-be-used-together++-------------------------------------------------------------------------------+-- Library+-------------------------------------------------------------------------------++library+ import: lib-options, bench-depends+ hs-source-dirs: lib+ exposed-modules:+ Streamly.Benchmark.Common++library lib-prelude+ import: lib-options, bench-depends+ hs-source-dirs: lib, .+ exposed-modules:+ Streamly.Benchmark.Prelude+ other-modules: Streamly.Benchmark.Common+ , Streamly.Benchmark.Prelude.NestedOps+ -- XXX GHCJS build fails for this library.+ if impl(ghcjs)+ buildable: False+ else+ build-depends: ghc-prim+ buildable: True++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++-- Whatever stack size below 32K we use GHC seems to report the stack size as+-- 32K at crash. Even K0K works. Therefore it probably does not make sense to+-- set it to lower than 32K.++common bench-options+ import: compile-options, optimization-options, bench-depends+ ghc-options: -with-rtsopts "-T -K32K -M16M"+ build-depends: streamly-benchmarks++-- Some benchmarks are threaded some are not+common bench-options-threaded+ import: compile-options, optimization-options, bench-depends+ -- -threaded and -N2 is important because some GC and space leak issues+ -- trigger only with these options.+ ghc-options: -threaded -with-rtsopts "-T -N2 -K32K -M16M"+ build-depends: streamly-benchmarks++-- XXX the individual modules can just export a bunch of gauge Benchmark+-- grouped by space usage and then we can combine the groups in just four+-- different top level drivers.++-------------------------------------------------------------------------------+-- Serial Streams+-------------------------------------------------------------------------------++benchmark linear+-- benchmark serial-o-1-space+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K36K -M16M"+ hs-source-dirs: Streamly/Benchmark/Prelude/Serial+ main-is: O_1_Space.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-prelude+ buildable: True++benchmark serial-o-n-heap+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K36K -M128M"+ hs-source-dirs: Streamly/Benchmark/Prelude/Serial+ main-is: O_n_Heap.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-prelude+ buildable: True++benchmark serial-o-n-stack+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K1M -M16M"+ hs-source-dirs: Streamly/Benchmark/Prelude/Serial+ main-is: O_n_Stack.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-prelude+ buildable: True++benchmark serial-o-n-space+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K16M -M64M"+ hs-source-dirs: Streamly/Benchmark/Prelude/Serial+ main-is: O_n_Space.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-prelude+ buildable: True++benchmark fold+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -rtsopts+ hs-source-dirs: Streamly/Benchmark/Data+ main-is: Fold.hs+ if impl(ghcjs)+ buildable: False+ else+ buildable: True++benchmark unfold+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -rtsopts+ hs-source-dirs: ., Streamly/Benchmark/Data+ main-is: Unfold.hs+ other-modules: Streamly.Benchmark.Data.NestedUnfoldOps+ if impl(ghcjs)+ buildable: False+ else+ buildable: True++benchmark parser+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K36K -M16M"+ hs-source-dirs: ., Streamly/Benchmark/Data+ main-is: Parser.hs+ if impl(ghcjs)+ buildable: False+ else+ buildable: True+ build-depends: exceptions >= 0.8 && < 0.11++-------------------------------------------------------------------------------+-- Raw Streams+-------------------------------------------------------------------------------++library lib-base+ import: lib-options, bench-depends+ hs-source-dirs: .+ exposed-modules:+ Streamly.Benchmark.Data.Stream.StreamD+ , Streamly.Benchmark.Data.Stream.StreamK+ , Streamly.Benchmark.Data.Stream.StreamDK+ if impl(ghcjs)+ buildable: False+ else+ build-depends: streamly-benchmarks+ buildable: True++benchmark base+-- benchmark base-o-1-space+ import: bench-options+ type: exitcode-stdio-1.0+ cpp-options: -DO_1_SPACE+ ghc-options: -with-rtsopts "-T -K36K -M16M"+ hs-source-dirs: Streamly/Benchmark/Data/Stream+ main-is: BaseStreams.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-base+ buildable: True++benchmark base-o-n-heap+ import: bench-options+ type: exitcode-stdio-1.0+ cpp-options: -DO_N_HEAP+ ghc-options: -with-rtsopts "-T -K36K -M64M"+ hs-source-dirs: Streamly/Benchmark/Data/Stream+ main-is: BaseStreams.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-base+ buildable: True++benchmark base-o-n-stack+ import: bench-options+ type: exitcode-stdio-1.0+ cpp-options: -DO_N_STACK+ ghc-options: -with-rtsopts "-T -K1M -M16M"+ hs-source-dirs: Streamly/Benchmark/Data/Stream+ main-is: BaseStreams.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-base+ buildable: True++benchmark base-o-n-space+ import: bench-options+ type: exitcode-stdio-1.0+ cpp-options: -DO_N_SPACE+ ghc-options: -with-rtsopts "-T -K32M -M32M"+ hs-source-dirs: Streamly/Benchmark/Data/Stream+ main-is: BaseStreams.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-base+ buildable: True++executable nano-bench+ import: bench-options+ hs-source-dirs: .+ main-is: NanoBenchmarks.hs+ if flag(dev)+ buildable: True+ else+ buildable: False++-------------------------------------------------------------------------------+-- Concurrent Streams+-------------------------------------------------------------------------------++benchmark linear-async+ import: bench-options-threaded+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -N2 -K64K -M16M"+ hs-source-dirs: Streamly/Benchmark/Prelude+ main-is: LinearAsync.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-prelude+ buildable: True++benchmark nested-concurrent+ import: bench-options-threaded+ type: exitcode-stdio-1.0+ -- XXX this can be lowered once we split out the finite benchmarks+ ghc-options: -with-rtsopts "-T -N2 -K256K -M128M"+ hs-source-dirs: ., Streamly/Benchmark/Prelude+ main-is: NestedConcurrent.hs+ other-modules: Streamly.Benchmark.Prelude.NestedOps++benchmark parallel+ import: bench-options-threaded+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -N2 -K128K -M256M"+ hs-source-dirs: Streamly/Benchmark/Prelude+ main-is: Parallel.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-prelude+ buildable: True++benchmark concurrent+ import: bench-options-threaded+ type: exitcode-stdio-1.0+ hs-source-dirs: Streamly/Benchmark/Prelude+ main-is: Concurrent.hs+ ghc-options: -with-rtsopts "-T -N2 -K256K -M384M"++benchmark adaptive+ import: bench-options-threaded+ type: exitcode-stdio-1.0+ hs-source-dirs: Streamly/Benchmark/Prelude+ main-is: Adaptive.hs+ if impl(ghcjs)+ buildable: False+ else+ buildable: True++benchmark linear-rate+ import: bench-options-threaded+ type: exitcode-stdio-1.0+ hs-source-dirs: Streamly/Benchmark/Prelude+ main-is: LinearRate.hs+ if impl(ghcjs)+ buildable: False+ else+ build-depends: lib-prelude+ buildable: True++-------------------------------------------------------------------------------+-- Array Benchmarks+-------------------------------------------------------------------------------++benchmark unpinned-array+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K1K -M128M"+ hs-source-dirs: .+ main-is: Streamly/Benchmark/Data/Array.hs+ other-modules: Streamly.Benchmark.Data.ArrayOps++benchmark prim-array+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K64K -M32M"+ hs-source-dirs: .+ main-is: Streamly/Benchmark/Data/Prim/Array.hs+ other-modules: Streamly.Benchmark.Data.Prim.ArrayOps++benchmark small-array+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K128K -M16M"+ hs-source-dirs: .+ main-is: Streamly/Benchmark/Data/SmallArray.hs+ other-modules: Streamly.Benchmark.Data.SmallArrayOps++benchmark array+ import: bench-options+ type: exitcode-stdio-1.0+ ghc-options: -with-rtsopts "-T -K64K -M128M"+ hs-source-dirs: .+ main-is: Streamly/Benchmark/Memory/Array.hs+ other-modules: Streamly.Benchmark.Memory.ArrayOps++-------------------------------------------------------------------------------+-- FileIO Benchmarks+-------------------------------------------------------------------------------++benchmark fileio+ import: bench-options+ type: exitcode-stdio-1.0+ hs-source-dirs: .+ main-is: FileIO.hs+ other-modules: Streamly.Benchmark.FileIO.Array+ , Streamly.Benchmark.FileIO.Stream+ build-depends:+ typed-process >= 0.2.3 && < 0.3++-------------------------------------------------------------------------------+-- benchmark comparison and presentation+-------------------------------------------------------------------------------++executable chart+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: .+ main-is: Chart.hs+ if flag(dev) && !flag(no-charts) && !impl(ghcjs)+ buildable: True+ build-Depends:+ base >= 4.8 && < 5+ , bench-show >= 0.3 && < 0.4+ , split+ , transformers >= 0.4 && < 0.6+ else+ buildable: False
configure view
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.69 for streamly 0.6.0.+# Generated by GNU Autoconf 2.69 for streamly 0.7.2. # # Report bugs to <streamly@composewell.com>. #@@ -580,8 +580,8 @@ # Identity of this package. PACKAGE_NAME='streamly' PACKAGE_TARNAME='streamly'-PACKAGE_VERSION='0.6.0'-PACKAGE_STRING='streamly 0.6.0'+PACKAGE_VERSION='0.7.2'+PACKAGE_STRING='streamly 0.7.2' PACKAGE_BUGREPORT='streamly@composewell.com' PACKAGE_URL='' @@ -652,6 +652,7 @@ docdir oldincludedir includedir+runstatedir localstatedir sharedstatedir sysconfdir@@ -723,6 +724,7 @@ sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var'+runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'@@ -975,6 +977,15 @@ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; + -runstatedir | --runstatedir | --runstatedi | --runstated \+ | --runstate | --runstat | --runsta | --runst | --runs \+ | --run | --ru | --r)+ ac_prev=runstatedir ;;+ -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \+ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \+ | --run=* | --ru=* | --r=*)+ runstatedir=$ac_optarg ;;+ -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \@@ -1112,7 +1123,7 @@ for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \- libdir localedir mandir+ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes.@@ -1225,7 +1236,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF-\`configure' configures streamly 0.6.0 to adapt to many kinds of systems.+\`configure' configures streamly 0.7.2 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1265,6 +1276,7 @@ --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var]+ --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include]@@ -1286,7 +1298,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in- short | recursive ) echo "Configuration of streamly 0.6.0:";;+ short | recursive ) echo "Configuration of streamly 0.7.2:";; esac cat <<\_ACEOF @@ -1371,7 +1383,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF-streamly configure 0.6.0+streamly configure 0.7.2 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc.@@ -1740,7 +1752,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by streamly $as_me 0.6.0, which was+It was created by streamly $as_me 0.7.2, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@@@ -3818,7 +3830,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log="-This file was extended by streamly $as_me 0.6.0, which was+This file was extended by streamly $as_me 0.7.2, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES@@ -3871,7 +3883,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\-streamly config.status 0.6.0+streamly config.status 0.7.2 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" @@ -4328,3 +4340,4 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi+
configure.ac view
@@ -3,7 +3,7 @@ # See https://www.gnu.org/software/autoconf/manual/autoconf.html for help on # the macros used in this file. -AC_INIT([streamly], [0.6.0], [streamly@composewell.com], [streamly])+AC_INIT([streamly], [0.7.2], [streamly@composewell.com], [streamly]) # To suppress "WARNING: unrecognized options: --with-compiler" AC_ARG_WITH([compiler], [GHC])
credits/CONTRIBUTORS.md view
@@ -4,6 +4,15 @@ Use `git shortlog -sn tag1...tag2` on the git repository to get a list of contributors between two repository tags. +## 0.7.2++* Harendra Kumar+* Pranay Sashank+* Adithya Kumar+* Sanchayan Maity+* Julian Ospald+* Shlok Datye+ ## 0.7.1 * Harendra Kumar
docs/Build.md view
@@ -8,11 +8,15 @@ Use the following GHC options: ```- -O2 - -fdicts-strict - -fspec-constr-recursive=16 + -O2+ -fdicts-strict -fmax-worker-args=16+ -fspec-constr-recursive=16 ```++Important Note: In certain cases it is possible that GHC takes too long to+compile with `-fspec-constr-recursive=16`, if that happens please reduce the+value or remove that option. ## Using Fusion Plugin
examples/EchoServer.hs view
@@ -1,19 +1,22 @@ -- A concurrent TCP server that echoes everything that it receives. -import Control.Exception (finally)-import Control.Monad.IO.Class (liftIO)+import Data.Function ((&))+ import Streamly+import Streamly.Internal.Network.Socket (handleWithM) import Streamly.Network.Socket-import qualified Network.Socket as Net+ import qualified Streamly.Network.Inet.TCP as TCP import qualified Streamly.Prelude as S main :: IO ()-main = S.drain- $ parallely $ S.mapM (useWith echo)- $ serially $ S.unfold TCP.acceptOnPort 8091+main =+ serially (S.unfold TCP.acceptOnPort 8091)+ & parallely . S.mapM (handleWithM echo)+ & S.drain+ where+ echo sk =- S.fold (writeChunks sk)- $ S.unfold readChunksWithBufferOf (32768, sk)- useWith f sk = finally (f sk) (liftIO (Net.close sk))+ S.unfold readChunksWithBufferOf (32768, sk) -- SerialT IO Socket+ & S.fold (writeChunks sk) -- IO ()
examples/WordClassifier.hs view
@@ -27,9 +27,9 @@ import System.Environment (getArgs) instance (Enum a, Storable a) => Hashable (A.Array a) where- hash arr = runIdentity $ IUF.fold A.read IFL.rollingHash arr- hashWithSalt salt arr = runIdentity $- IUF.fold A.read (IFL.rollingHashWithSalt salt) arr+ hash arr = fromIntegral $ runIdentity $ IUF.fold A.read IFL.rollingHash arr+ hashWithSalt salt arr = fromIntegral $ runIdentity $+ IUF.fold A.read (IFL.rollingHashWithSalt $ fromIntegral salt) arr {-# INLINE toLower #-} toLower :: Char -> Char
src/Streamly/FileSystem/IOVec.hsc view
@@ -22,7 +22,12 @@ ) where -import Data.Word (Word8, Word64)+import Data.Word (Word8)+#if defined(i386_HOST_ARCH)+import Data.Word (Word32)+#else+import Data.Word (Word64)+#endif import Foreign.C.Types (CInt(..)) import Foreign.Ptr (Ptr) import System.Posix.Types (CSsize(..))@@ -36,7 +41,11 @@ data IOVec = IOVec { iovBase :: {-# UNPACK #-} !(Ptr Word8)+#if defined(i386_HOST_ARCH)+ , iovLen :: {-# UNPACK #-} !Word32+#else , iovLen :: {-# UNPACK #-} !Word64+#endif } deriving (Eq, Show) #if !defined(mingw32_HOST_OS)@@ -56,7 +65,7 @@ return $ IOVec base len poke ptr vec = do let base = iovBase vec- len :: #{type size_t} = iovLen vec+ len :: #{type size_t} = iovLen vec #{poke struct iovec, iov_base} ptr base #{poke struct iovec, iov_len} ptr len #endif
src/Streamly/Internal/Data/Fold.hs view
@@ -142,6 +142,25 @@ , lsessionsOf , lchunksOf + -- ** Breaking++ -- Binary+ , splitAt -- spanN+ -- , splitIn -- sessionN++ -- By elements+ , span -- spanWhile+ , break -- breakBefore+ -- , breakAfter+ -- , breakOn+ -- , breakAround+ , spanBy+ , spanByRolling++ -- By sequences+ -- , breakOnSeq+ -- , breakOnStream -- on a stream+ -- * Distributing , tee@@ -174,15 +193,15 @@ -- , unzipWith -- , unzipWithM + -- * Nested Folds+ -- , concatMap+ , foldChunks+ , duplicate+ -- * Running Folds , initialize , runStep - -- * Nested Folds- -- , concatMap- -- , chunksOf- , duplicate -- experimental- -- * Folding to SVar , toParallelSVar , toParallelSVarLimited@@ -192,6 +211,7 @@ import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(..)) import Data.Functor.Identity (Identity(..))+import Data.Int (Int64) import Data.Map.Strict (Map) import Prelude@@ -537,22 +557,18 @@ -- -- @since 0.7.0 {-# INLINABLE rollingHashWithSalt #-}-rollingHashWithSalt :: (Monad m, Enum a) => Int -> Fold m a Int+rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64 rollingHashWithSalt salt = Fold step initial extract where- k = 2891336453+ k = 2891336453 :: Int64 initial = return salt- step cksum a = return $ cksum * k + fromEnum a+ step cksum a = return $ cksum * k + fromIntegral (fromEnum a) extract = return -- | A default salt used in the implementation of 'rollingHash'. {-# INLINE defaultSalt #-}-defaultSalt :: Int-#if WORD_SIZE_IN_BITS == 64-defaultSalt = 0xdc36d1615b7400a4-#else-defaultSalt = 0x087fc72c-#endif+defaultSalt :: Int64+defaultSalt = -2578643520546668380 -- | Compute an 'Int' sized polynomial rolling hash of a stream. --@@ -560,7 +576,7 @@ -- -- @since 0.7.0 {-# INLINABLE rollingHash #-}-rollingHash :: (Monad m, Enum a) => Fold m a Int+rollingHash :: (Monad m, Enum a) => Fold m a Int64 rollingHash = rollingHashWithSalt defaultSalt -- | Compute an 'Int' sized polynomial rolling hash of the first n elements of@@ -568,7 +584,7 @@ -- -- > rollingHashFirstN = ltake n rollingHash {-# INLINABLE rollingHashFirstN #-}-rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int+rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int64 rollingHashFirstN n = ltake n rollingHash ------------------------------------------------------------------------------@@ -804,6 +820,227 @@ or = Fold (\x a -> return $ x || a) (return False) return ------------------------------------------------------------------------------+-- Grouping/Splitting+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- Grouping without looking at elements+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- Binary APIs+------------------------------------------------------------------------------+--+-- XXX These would just be applicative compositions of terminating folds.++-- | @splitAt n f1 f2@ composes folds @f1@ and @f2@ such that first @n@+-- elements of its input are consumed by fold @f1@ and the rest of the stream+-- is consumed by fold @f2@.+--+-- > let splitAt_ n xs = S.fold (FL.splitAt n FL.toList FL.toList) $ S.fromList xs+--+-- >>> splitAt_ 6 "Hello World!"+-- > ("Hello ","World!")+--+-- >>> splitAt_ (-1) [1,2,3]+-- > ([],[1,2,3])+--+-- >>> splitAt_ 0 [1,2,3]+-- > ([],[1,2,3])+--+-- >>> splitAt_ 1 [1,2,3]+-- > ([1],[2,3])+--+-- >>> splitAt_ 3 [1,2,3]+-- > ([1,2,3],[])+--+-- >>> splitAt_ 4 [1,2,3]+-- > ([1,2,3],[])+--+-- /Internal/++-- This can be considered as a two-fold version of 'ltake' where we take both+-- the segments instead of discarding the leftover.+--+{-# INLINE splitAt #-}+splitAt+ :: Monad m+ => Int+ -> Fold m a b+ -> Fold m a c+ -> Fold m a (b, c)+splitAt n (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+ Fold step initial extract+ where+ initial = Tuple3' <$> return n <*> initialL <*> initialR++ step (Tuple3' i xL xR) input =+ if i > 0+ then stepL xL input >>= (\a -> return (Tuple3' (i - 1) a xR))+ else stepR xR input >>= (\b -> return (Tuple3' i xL b))++ extract (Tuple3' _ a b) = (,) <$> extractL a <*> extractR b++------------------------------------------------------------------------------+-- Element Aware APIs+------------------------------------------------------------------------------+--+------------------------------------------------------------------------------+-- Binary APIs+------------------------------------------------------------------------------++-- | Break the input stream into two groups, the first group takes the input as+-- long as the predicate applied to the first element of the stream and next+-- input element holds 'True', the second group takes the rest of the input.+--+-- /Internal/+--+spanBy+ :: Monad m+ => (a -> a -> Bool)+ -> Fold m a b+ -> Fold m a c+ -> Fold m a (b, c)+spanBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+ Fold step initial extract++ where+ initial = Tuple3' <$> initialL <*> initialR <*> return (Tuple' Nothing True)++ step (Tuple3' a b (Tuple' (Just frst) isFirstG)) input =+ if cmp frst input && isFirstG+ then stepL a input+ >>= (\a' -> return (Tuple3' a' b (Tuple' (Just frst) isFirstG)))+ else stepR b input+ >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False)))++ step (Tuple3' a b (Tuple' Nothing isFirstG)) input =+ if isFirstG+ then stepL a input+ >>= (\a' -> return (Tuple3' a' b (Tuple' (Just input) isFirstG)))+ else stepR b input+ >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False)))++ extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b++-- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the+-- input as long as the predicate @p@ is 'True'. @f2@ consumes the rest of the+-- input.+--+-- > let span_ p xs = S.fold (S.span p FL.toList FL.toList) $ S.fromList xs+--+-- >>> span_ (< 1) [1,2,3]+-- > ([],[1,2,3])+--+-- >>> span_ (< 2) [1,2,3]+-- > ([1],[2,3])+--+-- >>> span_ (< 4) [1,2,3]+-- > ([1,2,3],[])+--+-- /Internal/++-- This can be considered as a two-fold version of 'ltakeWhile' where we take+-- both the segments instead of discarding the leftover.+{-# INLINE span #-}+span+ :: Monad m+ => (a -> Bool)+ -> Fold m a b+ -> Fold m a c+ -> Fold m a (b, c)+span p (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+ Fold step initial extract++ where++ initial = Tuple3' <$> initialL <*> initialR <*> return True++ step (Tuple3' a b isFirstG) input =+ if isFirstG && p input+ then stepL a input >>= (\a' -> return (Tuple3' a' b True))+ else stepR b input >>= (\a' -> return (Tuple3' a a' False))++ extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b++-- |+-- > break p = span (not . p)+--+-- Break as soon as the predicate becomes 'True'. @break p f1 f2@ composes+-- folds @f1@ and @f2@ such that @f1@ stops consuming input as soon as the+-- predicate @p@ becomes 'True'. The rest of the input is consumed @f2@.+--+-- This is the binary version of 'splitBy'.+--+-- > let break_ p xs = S.fold (S.break p FL.toList FL.toList) $ S.fromList xs+--+-- >>> break_ (< 1) [3,2,1]+-- > ([3,2,1],[])+--+-- >>> break_ (< 2) [3,2,1]+-- > ([3,2],[1])+--+-- >>> break_ (< 4) [3,2,1]+-- > ([],[3,2,1])+--+-- /Internal/+{-# INLINE break #-}+break+ :: Monad m+ => (a -> Bool)+ -> Fold m a b+ -> Fold m a c+ -> Fold m a (b, c)+break p = span (not . p)++-- | Like 'spanBy' but applies the predicate in a rolling fashion i.e.+-- predicate is applied to the previous and the next input elements.+--+-- /Internal/+{-# INLINE spanByRolling #-}+spanByRolling+ :: Monad m+ => (a -> a -> Bool)+ -> Fold m a b+ -> Fold m a c+ -> Fold m a (b, c)+spanByRolling cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+ Fold step initial extract++ where+ initial = Tuple3' <$> initialL <*> initialR <*> return Nothing++ step (Tuple3' a b (Just frst)) input =+ if cmp input frst+ then stepL a input >>= (\a' -> return (Tuple3' a' b (Just input)))+ else stepR b input >>= (\b' -> return (Tuple3' a b' (Just input)))++ step (Tuple3' a b Nothing) input =+ stepL a input >>= (\a' -> return (Tuple3' a' b (Just input)))++ extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b++------------------------------------------------------------------------------+-- Binary splitting on a separator+------------------------------------------------------------------------------++{-+-- | Find the first occurrence of the specified sequence in the input stream+-- and break the input stream into two parts, the first part consisting of the+-- stream before the sequence and the second part consisting of the sequence+-- and the rest of the stream.+--+-- > let breakOn_ pat xs = S.fold (S.breakOn pat FL.toList FL.toList) $ S.fromList xs+--+-- >>> breakOn_ "dear" "Hello dear world!"+-- > ("Hello ","dear world!")+--+{-# INLINE breakOn #-}+breakOn :: Monad m => Array a -> Fold m a b -> Fold m a c -> Fold m a (b,c)+breakOn pat f m = undefined+-}++------------------------------------------------------------------------------ -- Distributing ------------------------------------------------------------------------------ --@@ -1258,7 +1495,7 @@ ------------------------------------------------------------------------------ -- Nesting ---------------------------------------------------------------------------------+ {- -- All the stream flattening transformations can also be applied to a fold -- input stream.@@ -1271,9 +1508,24 @@ -} -- All the grouping transformation that we apply to a stream can also be--- applied to a fold input stream.+-- applied to a fold input stream. groupBy et al can be written as terminating+-- folds and then we can apply foldChunks to use those repeatedly on a stream. +-- | Apply a terminating fold repeatedly to the input of another fold.+--+-- Compare with: Streamly.Prelude.concatMap, Streamly.Prelude.foldChunks+--+-- /Unimplemented/+--+{-# INLINABLE foldChunks #-}+foldChunks ::+ -- Monad m =>+ Fold m a b -> Fold m b c -> Fold m a c+foldChunks = undefined+ {-+-- XXX this would be an application of foldChunks using a terminating fold.+-- -- | Group the input stream into groups of elements between @low@ and @high@. -- Collection starts in chunks of @low@ and then keeps doubling until we reach -- @high@. Each chunk is folded using the provided fold function.
src/Streamly/Internal/Data/Fold/Types.hs view
@@ -10,12 +10,123 @@ -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC+--+-- = Stream Consumers+--+-- We can classify stream consumers in the following categories in order of+-- increasing complexity and power:+--+-- == Accumulators+--+-- These are the simplest folds that never fail and never terminate, they+-- accumulate the input values forever and always remain @partial@ and+-- @complete@ at the same time. It means that we can keep adding more input to+-- them or at any time retrieve a consistent result. A+-- 'Streamly.Internal.Data.Fold.sum' operation is an example of an accumulator.+--+-- We can distribute an input stream to two or more accumulators using a @tee@+-- style composition. Accumulators cannot be applied on a stream one after the+-- other, which we call a @split@ style composition, as the first one itself+-- will never terminate, therefore, the next one will never get to run.+--+-- == Splitters+--+-- Splitters are accumulators that can terminate. When applied on a stream+-- splitters consume part of the stream, thereby, splitting it. Splitters can+-- be used in a @split@ style composition where one splitter can be applied+-- after the other on an input stream. We can apply a splitter repeatedly on an+-- input stream splitting and consuming it in fragments. Splitters never fail,+-- therefore, they do not need backtracking, but they can lookahead and return+-- unconsumed input. The 'Streamly.Internal.Data.Parser.take' operation is an+-- example of a splitter. It terminates after consuming @n@ items. Coupled with+-- an accumulator it can be used to split the stream into chunks of fixed size.+--+-- Consider the example of @takeWhile@ operation, it needs to inspect an+-- element for termination decision. However, it does not consume the element+-- on which it terminates. To implement @takeWhile@ a splitter will have to+-- implement a way to return unconsumed input to the driver.+--+-- == Parsers+--+-- Parsers are splitters that can fail and backtrack. Parsers can be composed+-- using an @alternative@ style composition where they can backtrack and apply+-- another parser if one parser fails. 'Streamly.Internal.Data.Parser.satisfy'+-- is a simple example of a parser, it would succeed if the condition is+-- satisfied and it would fail otherwise, on failure an alternative parser can+-- be used on the same input.+--+-- = Types for Stream Consumers+--+-- We use the 'Fold' type to implement the Accumulator and Splitter+-- functionality. Parsers are represented by the+-- 'Streamly.Internal.Data.Parser.Parser' type. This is a sweet spot to+-- balance ease of use, type safety and performance. Using separate+-- Accumulator and Splitter types would encode more information in types but it+-- would make ease of use, implementation, maintenance effort worse. Combining+-- Accumulator, Splitter and Parser into a single+-- 'Streamly.Internal.Data.Parser.Parser' type would make ease of use even+-- better but type safety and performance worse.+--+-- One of the design requirements that we have placed for better ease of use+-- and code reuse is that 'Streamly.Internal.Data.Parser.Parser' type should be+-- a strict superset of the 'Fold' type i.e. it can do everything that a 'Fold'+-- can do and more. Therefore, folds can be easily upgraded to parsers and we+-- can use parser combinators on folds as well when needed.+--+-- = Fold Design+--+-- A fold is represented by a collection of "initial", "step" and "extract"+-- functions. The "initial" action generates the initial state of the fold. The+-- state is internal to the fold and maintains the accumulated output. The+-- "step" function is invoked using the current state and the next input value+-- and results in a @Yield@ or @Stop@. A @Yield@ returns the next intermediate+-- state of the fold, a @Stop@ indicates that the fold has terminated and+-- returns the final value of the accumulator.+--+-- Every @Yield@ indicates that a new accumulated output is available. The+-- accumulated output can be extracted from the state at any point using+-- "extract". "extract" can never fail. A fold returns a valid output even+-- without any input i.e. even if you call "extract" on "initial" state it+-- provides an output. This is not true for parsers.+--+-- In general, "extract" is used in two cases:+--+-- * When the fold is used as a scan @extract@ is called on the intermediate+-- state every time it is yielded by the fold, the resulting value is yielded+-- as a stream.+-- * When the fold is used as a regular fold, @extract@ is called once when+-- we are done feeding input to the fold.+--+-- = Alternate Designs+--+-- An alternate and simpler design would be to return the intermediate output+-- via @Yield@ along with the state, instead of using "extract" on the yielded+-- state and remove the extract function altogether.+--+-- This may even facilitate more efficient implementation. Extract from the+-- intermediate state after each yield may be more costly compared to the fold+-- step itself yielding the output. The fold may have more efficient ways to+-- retrieve the output rather than stuffing it in the state and using extract+-- on the state.+--+-- However, removing extract altogether may lead to less optimal code in some+-- cases because the driver of the fold needs to thread around the intermediate+-- output to return it if the stream stops before the fold could @Stop@. When+-- using this approach, the @splitParse (FL.take filesize)@ benchmark shows a+-- 2x worse performance even after ensuring everything fuses. So we keep the+-- "extract" approach to ensure better perf in all cases.+--+-- But we could still yield both state and the output in @Yield@, the output+-- can be used for the scan use case, instead of using extract. Extract would+-- then be used only for the case when the stream stops before the fold+-- completes. module Streamly.Internal.Data.Fold.Types ( Fold (..) , Fold2 (..) , simplify , toListRevF -- experimental+ -- $toListRevF , lmap , lmapM , lfilter@@ -52,13 +163,13 @@ -- Monadic left folds ------------------------------------------------------------------------------ --- | Represents a left fold over an input stream of values of type @a@ to a--- single value of type @b@ in 'Monad' @m@.+-- | Represents a left fold over an input stream consisting of values of type+-- @a@ to a single value of type @b@ in 'Monad' @m@. -- -- The fold uses an intermediate state @s@ as accumulator. The @step@ function--- updates the state and returns the new updated state. When the fold is done+-- updates the state and returns the new state. When the fold is done -- the final result of the fold is extracted from the intermediate state--- representation using the @extract@ function.+-- using the @extract@ function. -- -- @since 0.7.0 @@ -66,7 +177,7 @@ -- | @Fold @ @ step @ @ initial @ @ extract@ forall s. Fold (s -> a -> m s) (m s) (s -> m b) --- Experimental type to provide a side input to the fold for generating the+-- | Experimental type to provide a side input to the fold for generating the -- initial state. For example, if we have to fold chunks of a stream and write -- each chunk to a different file, then we can generate the file name using a -- monadic action. This is a generalized version of 'Fold'.@@ -80,15 +191,12 @@ simplify (Fold2 step inject extract) c = Fold step (inject c) extract -- | Maps a function on the output of the fold (the type @b@).-instance Applicative m => Functor (Fold m a) where+instance Functor m => Functor (Fold m a) where {-# INLINE fmap #-} fmap f (Fold step start done) = Fold step start done' where done' x = fmap f $! done x - {-# INLINE (<$) #-}- (<$) b = \_ -> pure b- -- | The fold resulting from '<*>' distributes its input to both the argument -- folds and combines their output using the supplied function. instance Applicative m => Applicative (Fold m a) where@@ -102,12 +210,6 @@ done (Tuple' xL xR) = doneL xL <*> doneR xR in Fold step begin done - {-# INLINE (<*) #-}- (<*) m = \_ -> m-- {-# INLINE (*>) #-}- _ *> m = m- -- | Combines the outputs of the folds (the type @b@) using their 'Semigroup' -- instances. instance (Semigroup b, Monad m) => Semigroup (Fold m a b) where@@ -217,9 +319,10 @@ -- Internal APIs ------------------------------------------------------------------------------ --- This is more efficient than 'toList'. toList is exactly the same as--- reversing the list after toListRev.---+-- $toListRevF+-- This is more efficient than 'Streamly.Internal.Data.Fold.toList'. toList is+-- exactly the same as reversing the list after 'toListRevF'.+ -- | Buffers the input stream to a list in the reverse order of the input. -- -- /Warning!/ working on large lists accumulated as buffers in memory could be@@ -286,8 +389,14 @@ lcatMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b lcatMaybes = lfilter isJust . lmap fromJust --- | Take first 'n' elements from the stream and discard the rest.+------------------------------------------------------------------------------+-- Parsing+------------------------------------------------------------------------------++-- XXX These should become terminating folds. --+-- | Take first @n@ elements from the stream and discard the rest.+-- -- @since 0.7.0 {-# INLINABLE ltake #-} ltake :: Monad m => Int -> Fold m a b -> Fold m a b@@ -356,6 +465,13 @@ i <- initial r <- step i a return $ (Fold step (return r) extract)++------------------------------------------------------------------------------+-- Parsing+------------------------------------------------------------------------------++-- XXX These can be expressed using foldChunks repeatedly on the input of a+-- fold. -- | For every n input items, apply the first fold and supply the result to the -- next fold.
+ src/Streamly/Internal/Data/Parser.hs view
@@ -0,0 +1,869 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Streamly.Internal.Data.Parser+-- Copyright : (c) 2020 Composewell Technologies+-- License : BSD3+-- Maintainer : streamly@composewell.com+-- Stability : experimental+-- Portability : GHC+--+-- Fast streaming parsers.+--+-- 'Applicative' and 'Alternative' type class based combinators from the+-- <http://hackage.haskell.org/package/parser-combinators parser-combinators>+-- package can also be used with the 'Parser' type. However, there are two+-- important differences between @parser-combinators@ and the equivalent ones+-- provided in this module in terms of performance:+--+-- 1) @parser-combinators@ use plain Haskell lists to collect the results, in a+-- strict Monad like IO, the results are necessarily buffered before they can+-- be consumed. This may not perform optimally in streaming applications+-- processing large amounts of data. Equivalent combinators in this module can+-- consume the results of parsing using a 'Fold', thus providing a scalability+-- and a generic consumer.+--+-- 2) Several combinators in this module can be many times faster because of+-- stream fusion. For example, 'Streamly.Internal.Data.Parser.many' combinator+-- in this module is much faster than the 'Control.Applicative.many' combinator+-- of 'Alternative' type class.+--+-- Failing parsers in this module throw the 'ParseError' exception.++-- XXX As far as possible, try that the combinators in this module and in+-- "Text.ParserCombinators.ReadP/parser-combinators/parsec/megaparsec/attoparsec"+-- have consistent names. takeP/takeWhileP/munch?++module Streamly.Internal.Data.Parser+ (+ Parser (..)++ -- First order parsers+ -- * Accumulators+ , fromFold+ , any+ , all+ , yield+ , yieldM+ , die+ , dieM++ -- * Element parsers+ , peek+ , eof+ , satisfy++ -- * Sequence parsers+ --+ -- Parsers chained in series, if one parser terminates the composition+ -- terminates. Currently we are using folds to collect the output of the+ -- parsers but we can use Parsers instead of folds to make the composition+ -- more powerful. For example, we can do:+ --+ -- sliceSepByMax cond n p = sliceBy cond (take n p)+ -- sliceSepByBetween cond m n p = sliceBy cond (takeBetween m n p)+ -- takeWhileBetween cond m n p = takeWhile cond (takeBetween m n p)+ --+ -- Grab a sequence of input elements without inspecting them+ , take+ -- , takeBetween+ -- , takeLE -- take -- takeBetween 0 n+ -- , takeLE1 -- take1 -- takeBetween 1 n+ , takeEQ -- takeBetween n n+ , takeGE -- takeBetween n maxBound++ -- Grab a sequence of input elements by inspecting them+ , lookAhead+ , takeWhile+ , takeWhile1+ , sliceSepBy+ , sliceSepByMax+ -- , sliceSepByBetween+ , sliceEndWith+ , sliceBeginWith+ -- , sliceSepWith+ --+ -- , frameSepBy -- parse frames escaped by an escape char/sequence+ -- , frameEndWith+ --+ , wordBy+ , groupBy+ , eqBy+ -- , prefixOf -- match any prefix of a given string+ -- , suffixOf -- match any suffix of a given string+ -- , infixOf -- match any substring of a given string++ -- Second order parsers (parsers using parsers)+ -- * Binary Combinators++ -- ** Sequential Applicative+ , splitWith++ -- ** Parallel Applicatives+ , teeWith+ , teeWithFst+ , teeWithMin+ -- , teeTill -- like manyTill but parallel++ -- ** Sequential Interleaving+ -- Use two folds, run a primary parser, its rejected values go to the+ -- secondary parser.+ , deintercalate++ -- ** Parallel Alternatives+ , shortest+ , longest+ -- , fastest++ -- * N-ary Combinators+ -- ** Sequential Collection+ , sequence++ -- ** Sequential Repetition+ , count+ , countBetween+ -- , countBetweenTill++ , many+ , some+ , manyTill++ -- -- ** Special cases+ -- XXX traditional implmentations of these may be of limited use. For+ -- example, consider parsing lines separated by "\r\n". The main parser+ -- will have to detect and exclude the sequence "\r\n" anyway so that we+ -- can apply the "sep" parser.+ --+ -- We can instead implement these as special cases of deintercalate.+ --+ -- , endBy+ -- , sepBy+ -- , sepEndBy+ -- , beginBy+ -- , sepBeginBy+ -- , sepAroundBy++ -- -- * Distribution+ --+ -- A simple and stupid impl would be to just convert the stream to an array+ -- and give the array reference to all consumers. The array can be grown on+ -- demand by any consumer and truncated when nonbody needs it.+ --+ -- -- ** Distribute to collection+ -- -- ** Distribute to repetition++ -- -- ** Interleaved collection+ -- Round robin+ -- Priority based+ -- -- ** Interleaved repetition+ -- repeat one parser and when it fails run an error recovery parser+ -- e.g. to find a key frame in the stream after an error++ -- ** Collection of Alternatives+ -- , shortestN+ -- , longestN+ -- , fastestN -- first N successful in time+ -- , choiceN -- first N successful in position+ , choice -- first successful in position++ -- -- ** Repeated Alternatives+ -- , retryMax -- try N times+ -- , retryUntil -- try until successful+ -- , retryUntilN -- try until successful n times+ )+where++import Control.Exception (assert)+import Control.Monad.Catch (MonadCatch, MonadThrow(..))+import Prelude+ hiding (any, all, take, takeWhile, sequence)++import Streamly.Internal.Data.Fold.Types (Fold(..))++import Streamly.Internal.Data.Parser.Tee+import Streamly.Internal.Data.Parser.Types+import Streamly.Internal.Data.Strict++-------------------------------------------------------------------------------+-- Upgrade folds to parses+-------------------------------------------------------------------------------+--+-- | The resulting parse never terminates and never errors out.+--+{-# INLINE fromFold #-}+fromFold :: Monad m => Fold m a b -> Parser m a b+fromFold (Fold fstep finitial fextract) = Parser step finitial fextract++ where++ step s a = Yield 0 <$> fstep s a++-------------------------------------------------------------------------------+-- Terminating but not failing folds+-------------------------------------------------------------------------------+--+-- |+-- >>> S.parse (PR.any (== 0)) $ S.fromList [1,0,1]+-- > Right True+--+{-# INLINABLE any #-}+any :: Monad m => (a -> Bool) -> Parser m a Bool+any predicate = Parser step initial return++ where++ initial = return False++ step s a = return $+ if s+ then Stop 0 True+ else+ if predicate a+ then Stop 0 True+ else Yield 0 False++-- |+-- >>> S.parse (PR.all (== 0)) $ S.fromList [1,0,1]+-- > Right False+--+{-# INLINABLE all #-}+all :: Monad m => (a -> Bool) -> Parser m a Bool+all predicate = Parser step initial return++ where++ initial = return True++ step s a = return $+ if s+ then+ if predicate a+ then Yield 0 True+ else Stop 0 False+ else Stop 0 False++-------------------------------------------------------------------------------+-- Failing Parsers+-------------------------------------------------------------------------------++-- | Peek the head element of a stream, without consuming it. Fails if it+-- encounters end of input.+--+-- >>> S.parse ((,) <$> PR.peek <*> PR.satisfy (> 0)) $ S.fromList [1]+-- (1,1)+--+-- @+-- peek = lookAhead (satisfy True)+-- @+--+-- /Internal/+--+{-# INLINABLE peek #-}+peek :: MonadThrow m => Parser m a a+peek = Parser step initial extract++ where++ initial = return ()++ step () a = return $ Stop 1 a++ extract () = throwM $ ParseError "peek: end of input"++-- | Succeeds if we are at the end of input, fails otherwise.+--+-- >>> S.parse ((,) <$> PR.satisfy (> 0) <*> PR.eof) $ S.fromList [1]+-- > (1,())+--+-- /Internal/+--+{-# INLINABLE eof #-}+eof :: Monad m => Parser m a ()+eof = Parser step initial return++ where++ initial = return ()++ step () _ = return $ Error "eof: not at end of input"++-- | Returns the next element if it passes the predicate, fails otherwise.+--+-- >>> S.parse (PR.satisfy (== 1)) $ S.fromList [1,0,1]+-- > 1+--+-- /Internal/+--+{-# INLINE satisfy #-}+satisfy :: MonadThrow m => (a -> Bool) -> Parser m a a+satisfy predicate = Parser step initial extract++ where++ initial = return ()++ step () a = return $+ if predicate a+ then Stop 0 a+ else Error "satisfy: predicate failed"++ extract _ = throwM $ ParseError "satisfy: end of input"++-------------------------------------------------------------------------------+-- Taking elements+-------------------------------------------------------------------------------+--+-- XXX Once we have terminating folds, this Parse should get replaced by Fold.+-- Alternatively, we can name it "chunkOf" and the corresponding time domain+-- combinator as "intervalOf" or even "chunk" and "interval".+--+-- | Take at most @n@ input elements and fold them using the supplied fold.+--+-- Stops after @n@ elements.+-- Never fails.+--+-- >>> S.parse (PR.take 1 FL.toList) $ S.fromList [1]+-- [1]+--+-- @+-- S.chunksOf n f = S.splitParse (FL.take n f)+-- @+--+-- /Internal/+--+{-# INLINE take #-}+take :: Monad m => Int -> Fold m a b -> Parser m a b+take n (Fold fstep finitial fextract) = Parser step initial extract++ where++ initial = Tuple' 0 <$> finitial++ step (Tuple' i r) a = do+ res <- fstep r a+ let i1 = i + 1+ s1 = Tuple' i1 res+ if i1 < n+ then return $ Yield 0 s1+ else Stop 0 <$> fextract res++ extract (Tuple' _ r) = fextract r++--+-- XXX can we use a "cmp" operation in a common implementation?+--+-- | Stops after taking exactly @n@ input elements.+--+-- * Stops - after @n@ elements.+-- * Fails - if the stream ends before it can collect @n@ elements.+--+-- >>> S.parse (PR.takeEQ 4 FL.toList) $ S.fromList [1,0,1]+-- > "takeEQ: Expecting exactly 4 elements, got 3"+--+-- /Internal/+--+{-# INLINE takeEQ #-}+takeEQ :: MonadThrow m => Int -> Fold m a b -> Parser m a b+takeEQ n (Fold fstep finitial fextract) = Parser step initial extract++ where++ initial = Tuple' 0 <$> finitial++ step (Tuple' i r) a = do+ res <- fstep r a+ let i1 = i + 1+ s1 = Tuple' i1 res+ if i1 < n then return (Skip 0 s1) else Stop 0 <$> fextract res++ extract (Tuple' i r) =+ if n == i+ then fextract r+ else throwM $ ParseError err++ where++ err =+ "takeEQ: Expecting exactly " ++ show n+ ++ " elements, got " ++ show i++-- | Take at least @n@ input elements, but can collect more.+--+-- * Stops - never.+-- * Fails - if the stream ends before producing @n@ elements.+--+-- >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1]+-- > "takeGE: Expecting at least 4 elements, got only 3"+--+-- >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1,0,1]+-- > [1,0,1,0,1]+--+-- /Internal/+--+{-# INLINE takeGE #-}+takeGE :: MonadThrow m => Int -> Fold m a b -> Parser m a b+takeGE n (Fold fstep finitial fextract) = Parser step initial extract++ where++ initial = Tuple' 0 <$> finitial++ step (Tuple' i r) a = do+ res <- fstep r a+ let i1 = i + 1+ s1 = Tuple' i1 res+ return $+ if i1 < n+ then Skip 0 s1+ else Yield 0 s1++ extract (Tuple' i r) = fextract r >>= f++ where++ err =+ "takeGE: Expecting at least " ++ show n+ ++ " elements, got only " ++ show i++ f x =+ if i >= n+ then return x+ else throwM $ ParseError err++-- | Collect stream elements until an element fails the predicate. The element+-- on which the predicate fails is returned back to the input stream.+--+-- * Stops - when the predicate fails.+-- * Fails - never.+--+-- >>> S.parse (PR.takeWhile (== 0) FL.toList) $ S.fromList [0,0,1,0,1]+-- > [0,0]+--+-- We can implement a @breakOn@ using 'takeWhile':+--+-- @+-- breakOn p = takeWhile (not p)+-- @+--+-- /Internal/+--+{-# INLINE takeWhile #-}+takeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Parser m a b+takeWhile predicate (Fold fstep finitial fextract) =+ Parser step initial fextract++ where++ initial = finitial++ step s a =+ if predicate a+ then Yield 0 <$> fstep s a+ else Stop 1 <$> fextract s++-- | Like 'takeWhile' but takes at least one element otherwise fails.+--+-- /Internal/+--+{-# INLINE takeWhile1 #-}+takeWhile1 :: MonadThrow m => (a -> Bool) -> Fold m a b -> Parser m a b+takeWhile1 predicate (Fold fstep finitial fextract) =+ Parser step initial extract++ where++ initial = return Nothing++ step Nothing a =+ if predicate a+ then do+ s <- finitial+ r <- fstep s a+ return $ Yield 0 (Just r)+ else return $ Error "takeWhile1: empty"+ step (Just s) a =+ if predicate a+ then do+ r <- fstep s a+ return $ Yield 0 (Just r)+ else do+ b <- fextract s+ return $ Stop 1 b++ extract Nothing = throwM $ ParseError "takeWhile1: end of input"+ extract (Just s) = fextract s++-- | Collect stream elements until an element succeeds the predicate. Drop the+-- element on which the predicate succeeded. The succeeding element is treated+-- as an infix separator which is dropped from the output.+--+-- * Stops - when the predicate succeeds.+-- * Fails - never.+--+-- >>> S.parse (PR.sliceSepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]+-- > [0,0]+--+-- S.splitOn pred f = S.splitParse (PR.sliceSepBy pred f)+--+-- >>> S.toList $ S.splitParse (PR.sliceSepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]+-- > [[0,0],[0],[]]+--+-- /Internal/+--+{-# INLINABLE sliceSepBy #-}+sliceSepBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser m a b+sliceSepBy predicate (Fold fstep finitial fextract) =+ Parser step initial fextract++ where++ initial = finitial+ step s a =+ if not (predicate a)+ then Yield 0 <$> fstep s a+ else Stop 0 <$> fextract s++-- | Collect stream elements until an element succeeds the predicate. Also take+-- the element on which the predicate succeeded. The succeeding element is+-- treated as a suffix separator which is kept in the output segement.+--+-- * Stops - when the predicate succeeds.+-- * Fails - never.+--+-- S.splitWithSuffix pred f = S.splitParse (PR.sliceEndWith pred f)+--+-- /Unimplemented/+--+{-# INLINABLE sliceEndWith #-}+sliceEndWith ::+ -- Monad m =>+ (a -> Bool) -> Fold m a b -> Parser m a b+sliceEndWith = undefined++-- | Collect stream elements until an elements passes the predicate, return the+-- last element on which the predicate succeeded back to the input stream. If+-- the predicate succeeds on the first element itself then it is kept in the+-- stream and we continue collecting. The succeeding element is treated as a+-- prefix separator which is kept in the output segement.+--+-- * Stops - when the predicate succeeds in non-leading position.+-- * Fails - never.+--+-- S.splitWithPrefix pred f = S.splitParse (PR.sliceBeginWith pred f)+--+-- /Unimplemented/+--+{-# INLINABLE sliceBeginWith #-}+sliceBeginWith ::+ -- Monad m =>+ (a -> Bool) -> Fold m a b -> Parser m a b+sliceBeginWith = undefined++-- | Split using a condition or a count whichever occurs first. This is a+-- hybrid of 'splitOn' and 'take'. The element on which the condition succeeds+-- is dropped.+--+-- /Internal/+--+{-# INLINABLE sliceSepByMax #-}+sliceSepByMax :: Monad m+ => (a -> Bool) -> Int -> Fold m a b -> Parser m a b+sliceSepByMax predicate cnt (Fold fstep finitial fextract) =+ Parser step initial extract++ where++ initial = Tuple' 0 <$> finitial+ step (Tuple' i r) a = do+ res <- fstep r a+ let i1 = i + 1+ s1 = Tuple' i1 res+ if not (predicate a) && i1 < cnt+ then return $ Yield 0 s1+ else do+ b <- fextract res+ return $ Stop 0 b+ extract (Tuple' _ r) = fextract r++-- | Like 'splitOn' but strips leading, trailing, and repeated separators.+-- Therefore, @".a..b."@ having '.' as the separator would be parsed as+-- @["a","b"]@. In other words, its like parsing words from whitespace+-- separated text.+--+-- * Stops - when it finds a word separator after a non-word element+-- * Fails - never.+--+-- @+-- S.wordsBy pred f = S.splitParse (PR.wordBy pred f)+-- @+--+-- /Unimplemented/+--+{-# INLINABLE wordBy #-}+wordBy ::+ -- Monad m =>+ (a -> Bool) -> Fold m a b -> Parser m a b+wordBy = undefined++-- | @groupBy cmp f $ S.fromList [a,b,c,...]@ assigns the element @a@ to the+-- first group, then if @a \`cmp` b@ is 'True' @b@ is also assigned to the same+-- group. If @a \`cmp` c@ is 'True' then @c@ is also assigned to the same+-- group and so on. When the comparison fails a new group is started. Each+-- group is folded using the 'Fold' @f@ and the result of the fold is emitted+-- in the output stream.+--+-- * Stops - when the comparison fails.+-- * Fails - never.+--+-- @+-- S.groupsBy cmp f = S.splitParse (PR.groupBy cmp f)+-- @+--+-- /Unimplemented/+--+{-# INLINABLE groupBy #-}+groupBy ::+ -- Monad m =>+ (a -> a -> Bool) -> Fold m a b -> Parser m a b+groupBy = undefined++-- XXX use an Unfold instead of a list?+-- XXX custom combinators for matching list, array and stream?+--+-- | Match the given sequence of elements using the given comparison function.+--+-- /Internal/+--+{-# INLINE eqBy #-}+eqBy :: MonadThrow m => (a -> a -> Bool) -> [a] -> Parser m a ()+eqBy cmp str = Parser step initial extract++ where++ initial = return str++ step [] _ = error "Bug: unreachable"+ step [x] a = return $+ if x `cmp` a+ then Stop 0 ()+ else Error $+ "eqBy: failed, at the last element"+ step (x:xs) a = return $+ if x `cmp` a+ then Skip 0 xs+ else Error $+ "eqBy: failed, yet to match " ++ show (length xs) ++ " elements"++ extract xs = throwM $ ParseError $+ "eqBy: end of input, yet to match " ++ show (length xs) ++ " elements"++-------------------------------------------------------------------------------+-- nested parsers+-------------------------------------------------------------------------------++{-# INLINE lookAhead #-}+lookAhead :: MonadThrow m => Parser m a b -> Parser m a b+lookAhead (Parser step1 initial1 _) =+ Parser step initial extract++ where++ initial = Tuple' 0 <$> initial1++ step (Tuple' cnt st) a = do+ r <- step1 st a+ let cnt1 = cnt + 1+ return $ case r of+ Yield _ s -> Skip 0 (Tuple' cnt1 s)+ Skip n s -> Skip n (Tuple' (cnt1 - n) s)+ Stop _ b -> Stop cnt1 b+ Error err -> Error err++ -- XXX returning an error let's us backtrack. To implement it in a way so+ -- that it terminates on eof without an error then we need a way to+ -- backtrack on eof, that will require extract to return 'Step' type.+ extract (Tuple' n _) = throwM $ ParseError $+ "lookAhead: end of input after consuming " ++ show n ++ " elements"++-------------------------------------------------------------------------------+-- Interleaving+-------------------------------------------------------------------------------+--+-- To deinterleave we can chain two parsers one behind the other. The input is+-- given to the first parser and the input definitively rejected by the first+-- parser is given to the second parser.+--+-- We can either have the parsers themselves buffer the input or use the shared+-- global buffer to hold it until none of the parsers need it. When the first+-- parser returns Skip (i.e. rewind) we let the second parser consume the+-- rejected input and when it is done we move the cursor forward to the first+-- parser again. This will require a "move forward" command as well.+--+-- To implement grep we can use three parsers, one to find the pattern, one+-- to store the context behind the pattern and one to store the context in+-- front of the pattern. When a match occurs we need to emit the accumulator of+-- all the three parsers. One parser can count the line numbers to provide the+-- line number info.+--+-- | Apply two parsers alternately to an input stream. The input stream is+-- considered an interleaving of two patterns. The two parsers represent the+-- two patterns.+--+-- This undoes a "gintercalate" of two streams.+--+-- /Unimplemented/+--+{-# INLINE deintercalate #-}+deintercalate ::+ -- Monad m =>+ Fold m a y -> Parser m x a+ -> Fold m b z -> Parser m x b+ -> Parser m x (y, z)+deintercalate = undefined++-------------------------------------------------------------------------------+-- Sequential Collection+-------------------------------------------------------------------------------+--+-- | @sequence f t@ collects sequential parses of parsers in the container @t@+-- using the fold @f@. Fails if the input ends or any of the parsers fail.+--+-- /Unimplemented/+--+{-# INLINE sequence #-}+sequence ::+ -- Foldable t =>+ Fold m b c -> t (Parser m a b) -> Parser m a c+sequence _f _p = undefined++-------------------------------------------------------------------------------+-- Alternative Collection+-------------------------------------------------------------------------------+--+-- | @choice parsers@ applies the @parsers@ in order and returns the first+-- successful parse.+--+{-# INLINE choice #-}+choice ::+ -- Foldable t =>+ t (Parser m a b) -> Parser m a b+choice _ps = undefined++-------------------------------------------------------------------------------+-- Sequential Repetition+-------------------------------------------------------------------------------+--+-- XXX "many" is essentially a Fold because it cannot fail. So it can be+-- downgraded to a Fold. Or we can make the return type a Fold instead and+-- upgrade that to a parser when needed.+--+-- | Collect zero or more parses. Apply the parser repeatedly on the input+-- stream, stop when the parser fails, accumulate zero or more parse results+-- using the supplied 'Fold'. This parser never fails, in case the first+-- application of parser fails it returns an empty result.+--+-- Compare with 'Control.Applicative.many'.+--+-- /Internal/+--+{-# INLINE many #-}+many :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c+many = splitMany+-- many = countBetween 0 maxBound++-- | Collect one or more parses. Apply the supplied parser repeatedly on the+-- input stream and accumulate the parse results as long as the parser+-- succeeds, stop when it fails. This parser fails if not even one result is+-- collected.+--+-- Compare with 'Control.Applicative.some'.+--+-- /Internal/+--+{-# INLINE some #-}+some :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c+some = splitSome+-- some f p = many (takeGE 1 f) p+-- many = countBetween 1 maxBound++-- | @countBetween m n f p@ collects between @m@ and @n@ sequential parses of+-- parser @p@ using the fold @f@. Stop after collecting @n@ results. Fails if+-- the input ends or the parser fails before @m@ results are collected.+--+-- /Unimplemented/+--+{-# INLINE countBetween #-}+countBetween ::+ -- MonadCatch m =>+ Int -> Int -> Fold m b c -> Parser m a b -> Parser m a c+countBetween _m _n _f = undefined+-- countBetween m n f p = many (takeBetween m n f) p++-- | @count n f p@ collects exactly @n@ sequential parses of parser @p@ using+-- the fold @f@. Fails if the input ends or the parser fails before @n@+-- results are collected.+--+-- /Unimplemented/+--+{-# INLINE count #-}+count ::+ -- MonadCatch m =>+ Int -> Fold m b c -> Parser m a b -> Parser m a c+count n = countBetween n n+-- count n f p = many (takeEQ n f) p++data ManyTillState fs sr sl = ManyTillR Int fs sr | ManyTillL fs sl++-- | @manyTill f collect test@ tries the parser @test@ on the input, if @test@+-- fails it backtracks and tries @collect@, after @collect@ succeeds @test@ is+-- tried again and so on. The parser stops when @test@ succeeds. The output of+-- @test@ is discarded and the output of @collect@ is accumulated by the+-- supplied fold. The parser fails if @collect@ fails.+--+-- /Internal/+--+{-# INLINE manyTill #-}+manyTill :: MonadCatch m+ => Fold m b c -> Parser m a b -> Parser m a x -> Parser m a c+manyTill (Fold fstep finitial fextract)+ (Parser stepL initialL extractL)+ (Parser stepR initialR _) =+ Parser step initial extract++ where++ initial = do+ fs <- finitial+ ManyTillR 0 fs <$> initialR++ step (ManyTillR cnt fs st) a = do+ r <- stepR st a+ case r of+ Yield n s -> return $ Yield n (ManyTillR 0 fs s)+ Skip n s -> do+ assert (cnt + 1 - n >= 0) (return ())+ return $ Skip n (ManyTillR (cnt + 1 - n) fs s)+ Stop n _ -> do+ b <- fextract fs+ return $ Stop n b+ Error _ -> do+ rR <- initialL+ return $ Skip (cnt + 1) (ManyTillL fs rR)++ step (ManyTillL fs st) a = do+ r <- stepL st a+ case r of+ Yield n s -> return $ Yield n (ManyTillL fs s)+ Skip n s -> return $ Skip n (ManyTillL fs s)+ Stop n b -> do+ fs1 <- fstep fs b+ l <- initialR+ -- XXX we need a yield with backtrack here+ -- return $ Yield n (ManyTillR 0 fs1 l)+ return $ Skip n (ManyTillR 0 fs1 l)+ Error err -> return $ Error err++ extract (ManyTillL fs sR) = extractL sR >>= fstep fs >>= fextract+ extract (ManyTillR _ fs _) = fextract fs
+ src/Streamly/Internal/Data/Parser/Tee.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#endif++#include "inline.hs"++-- |+-- Module : Streamly.Internal.Data.Parser.Tee+-- Copyright : (c) 2020 Composewell Technologies+-- License : BSD3+-- Maintainer : streamly@composewell.com+-- Stability : experimental+-- Portability : GHC+--+-- Parallel parsers. Distributing the input to multiple parsers at the same+-- time.+--+-- For simplicity, we are using code where a particular state is unreachable+-- but it is not prevented by types. Somehow uni-pattern match using "let"+-- produces better optimized code compared to using @case@ match and using+-- explicit error messages in unreachable cases.+--+-- There seem to be no way to silence individual warnings so we use a global+-- incomplete uni-pattern match warning suppression option for the file.+-- Disabling the warning for other code as well has the potential to mask off+-- some legit warnings, therefore, we have segregated only the code that uses+-- uni-pattern matches in this module.++module Streamly.Internal.Data.Parser.Tee+ (+ -- Parallel zipped+ teeWith+ , teeWithFst+ , teeWithMin++ -- Parallel alternatives+ , shortest+ , longest+ )+where++import Control.Exception (assert)+import Control.Monad.Catch (MonadCatch, try)+import Prelude+ hiding (any, all, takeWhile)++import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..), ParseError)++-------------------------------------------------------------------------------+-- Distribute input to two parsers and collect both results+-------------------------------------------------------------------------------++{-# ANN type StepState Fuse #-}+data StepState s a = StepState s | StepResult a++-- XXX Use a Zipper structure for buffering?+--+-- | State of the pair of parsers in a tee composition+-- Note: strictness annotation is important for fusing the constructors+{-# ANN type TeeState Fuse #-}+data TeeState sL sR x a b =+-- @TeePair (past buffer, parser state, future-buffer1, future-buffer2) ...@+ TeePair !([x], StepState sL a, [x], [x]) !([x], StepState sR b, [x], [x])++{-# ANN type Res Fuse #-}+data Res = Yld Int | Stp Int | Skp | Err String++-- XXX: With the current "Step" semantics, it is hard to write, and not sure+-- how useful, an efficient teeWith that returns a correct unused input count.+--+-- XXX Teeing a parser with a Fold could be more useful and simpler to+-- implement. A fold never fails or backtracks so we do not need to buffer the+-- input for the fold. It can be useful in, for example, maintaining the line+-- and column number position to report for errors. We can always have the+-- line/column fold running in parallel with the main parser, whenever an error+-- occurs we can zip the error with the context fold.+--+-- | @teeWith f p1 p2@ distributes its input to both @p1@ and @p2@ until both+-- of them succeed or fail and combines their output using @f@. The parser+-- succeeds if both the parsers succeed.+--+-- /Internal/+--+{-# INLINE teeWith #-}+teeWith :: Monad m+ => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =+ Parser step initial extract++ where++ {-# INLINE_LATE initial #-}+ initial = do+ sL <- initialL+ sR <- initialR+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])++ {-# INLINE consume #-}+ consume buf inp1 inp2 stp st y = do+ let (x, inp11, inp21) =+ case inp1 of+ [] -> (y, [], [])+ z : [] -> (z, reverse (x:inp2), [])+ z : zs -> (z, zs, x:inp2)+ r <- stp st x+ let buf1 = x:buf+ return (buf1, r, inp11, inp21)++ -- consume one input item and return the next state of the fold+ {-# INLINE useStream #-}+ useStream buf inp1 inp2 stp st y = do+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y+ case r of+ Yield n s ->+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)+ in assert (n <= length buf1) (return (state, Yld n))+ Stop n b ->+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)+ in assert (n <= length buf1) (return (state, Stp n))+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)+ Skip n s ->+ let (src0, buf2) = splitAt n buf1+ src = Prelude.reverse src0+ state = (buf2, StepState s, src ++ inp11, inp21)+ in assert (n <= length buf1) (return (state, Skp))+ Error err -> return (undefined, Err err)++ {-# INLINE_LATE step #-}+ step (TeePair (bufL, StepState sL, inpL1, inpL2)+ (bufR, StepState sR, inpR1, inpR2)) x = do+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x+ let next = TeePair l r+ return $ case (stL,stR) of+ (Yld n1, Yld n2) -> Yield (min n1 n2) next+ (Yld n1, Stp n2) -> Yield (min n1 n2) next+ (Stp n1, Yld n2) -> Yield (min n1 n2) next+ (Stp n1, Stp n2) ->+ -- Uni-pattern match results in better optimized code compared+ -- to a case match.+ let (_, StepResult rL, _, _) = l+ (_, StepResult rR, _, _) = r+ in Stop (min n1 n2) (zf rL rR)+ (Err err, _) -> Error err+ (_, Err err) -> Error err+ _ -> Skip 0 next++ step (TeePair (bufL, StepState sL, inpL1, inpL2)+ r@(_, StepResult rR, _, _)) x = do+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x+ let next = TeePair l r+ -- XXX If the unused count of this stream is lower than the unused+ -- count of the stopped stream, only then this will be correct. We need+ -- to fix the other case. We need to keep incrementing the unused count+ -- of the stopped stream and take the min of the two.+ return $ case stL of+ Yld n -> Yield n next+ Stp n ->+ let (_, StepResult rL, _, _) = l+ in Stop n (zf rL rR)+ Skp -> Skip 0 next+ Err err -> Error err++ step (TeePair l@(_, StepResult rL, _, _)+ (bufR, StepState sR, inpR1, inpR2)) x = do+ (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x+ let next = TeePair l r+ -- XXX If the unused count of this stream is lower than the unused+ -- count of the stopped stream, only then this will be correct. We need+ -- to fix the other case. We need to keep incrementing the unused count+ -- of the stopped stream and take the min of the two.+ return $ case stR of+ Yld n -> Yield n next+ Stp n ->+ let (_, StepResult rR, _, _) = r+ in Stop n (zf rL rR)+ Skp -> Skip 0 next+ Err err -> Error err++ step _ _ = undefined++ {-# INLINE_LATE extract #-}+ extract st =+ case st of+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do+ rL <- extractL sL+ rR <- extractR sR+ return $ zf rL rR+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do+ rL <- extractL sL+ return $ zf rL rR+ TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do+ rR <- extractR sR+ return $ zf rL rR+ TeePair (_, StepResult rL, _, _) (_, StepResult rR, _, _) ->+ return $ zf rL rR++-- | Like 'teeWith' but ends parsing and zips the results, if available,+-- whenever the first parser ends.+--+-- /Internal/+--+{-# INLINE teeWithFst #-}+teeWithFst :: Monad m+ => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+teeWithFst zf (Parser stepL initialL extractL)+ (Parser stepR initialR extractR) =+ Parser step initial extract++ where++ {-# INLINE_LATE initial #-}+ initial = do+ sL <- initialL+ sR <- initialR+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])++ {-# INLINE consume #-}+ consume buf inp1 inp2 stp st y = do+ let (x, inp11, inp21) =+ case inp1 of+ [] -> (y, [], [])+ z : [] -> (z, reverse (x:inp2), [])+ z : zs -> (z, zs, x:inp2)+ r <- stp st x+ let buf1 = x:buf+ return (buf1, r, inp11, inp21)++ -- consume one input item and return the next state of the fold+ {-# INLINE useStream #-}+ useStream buf inp1 inp2 stp st y = do+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y+ case r of+ Yield n s ->+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)+ in assert (n <= length buf1) (return (state, Yld n))+ Stop n b ->+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)+ in assert (n <= length buf1) (return (state, Stp n))+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)+ Skip n s ->+ let (src0, buf2) = splitAt n buf1+ src = Prelude.reverse src0+ state = (buf2, StepState s, src ++ inp11, inp21)+ in assert (n <= length buf1) (return (state, Skp))+ Error err -> return (undefined, Err err)++ {-# INLINE_LATE step #-}+ step (TeePair (bufL, StepState sL, inpL1, inpL2)+ (bufR, StepState sR, inpR1, inpR2)) x = do+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x+ let next = TeePair l r+ case (stL,stR) of+ -- XXX what if the first parser returns an unused count which is+ -- more than the second parser's unused count? It does not make+ -- sense for the second parser to consume more than the first+ -- parser. We reset the input cursor based on the first parser.+ -- Error out if the second one has consumed more then the first?+ (Stp n1, Stp _) ->+ -- Uni-pattern match results in better optimized code compared+ -- to a case match.+ let (_, StepResult rL, _, _) = l+ (_, StepResult rR, _, _) = r+ in return $ Stop n1 (zf rL rR)+ (Stp n1, Yld _) ->+ let (_, StepResult rL, _, _) = l+ (_, StepState ssR, _, _) = r+ in do+ rR <- extractR ssR+ return $ Stop n1 (zf rL rR)+ (Yld n1, Yld n2) -> return $ Yield (min n1 n2) next+ (Yld n1, Stp n2) -> return $ Yield (min n1 n2) next+ (Err err, _) -> return $ Error err+ (_, Err err) -> return $ Error err+ _ -> return $ Skip 0 next++ step (TeePair (bufL, StepState sL, inpL1, inpL2)+ r@(_, StepResult rR, _, _)) x = do+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x+ let next = TeePair l r+ -- XXX If the unused count of this stream is lower than the unused+ -- count of the stopped stream, only then this will be correct. We need+ -- to fix the other case. We need to keep incrementing the unused count+ -- of the stopped stream and take the min of the two.+ return $ case stL of+ Yld n -> Yield n next+ Stp n ->+ let (_, StepResult rL, _, _) = l+ in Stop n (zf rL rR)+ Skp -> Skip 0 next+ Err err -> Error err++ step _ _ = undefined++ {-# INLINE_LATE extract #-}+ extract st =+ case st of+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do+ rL <- extractL sL+ rR <- extractR sR+ return $ zf rL rR+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do+ rL <- extractL sL+ return $ zf rL rR+ _ -> error "unreachable"++-- | Like 'teeWith' but ends parsing and zips the results, if available,+-- whenever any of the parsers ends or fails.+--+-- /Unimplemented/+--+{-# INLINE teeWithMin #-}+teeWithMin ::+ -- Monad m =>+ (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+teeWithMin = undefined++-------------------------------------------------------------------------------+-- Distribute input to two parsers and choose one result+-------------------------------------------------------------------------------++-- | Shortest alternative. Apply both parsers in parallel but choose the result+-- from the one which consumed least input i.e. take the shortest succeeding+-- parse.+--+-- /Internal/+--+{-# INLINE shortest #-}+shortest :: Monad m => Parser m x a -> Parser m x a -> Parser m x a+shortest (Parser stepL initialL extractL) (Parser stepR initialR _) =+ Parser step initial extract++ where++ {-# INLINE_LATE initial #-}+ initial = do+ sL <- initialL+ sR <- initialR+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])++ {-# INLINE consume #-}+ consume buf inp1 inp2 stp st y = do+ let (x, inp11, inp21) =+ case inp1 of+ [] -> (y, [], [])+ z : [] -> (z, reverse (x:inp2), [])+ z : zs -> (z, zs, x:inp2)+ r <- stp st x+ let buf1 = x:buf+ return (buf1, r, inp11, inp21)++ -- consume one input item and return the next state of the fold+ {-# INLINE useStream #-}+ useStream buf inp1 inp2 stp st y = do+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y+ case r of+ Yield n s ->+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)+ in assert (n <= length buf1) (return (state, Yld n))+ Stop n b ->+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)+ in assert (n <= length buf1) (return (state, Stp n))+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)+ Skip n s ->+ let (src0, buf2) = splitAt n buf1+ src = Prelude.reverse src0+ state = (buf2, StepState s, src ++ inp11, inp21)+ in assert (n <= length buf1) (return (state, Skp))+ Error err -> return (undefined, Err err)++ -- XXX Even if a parse finished earlier it may not be shortest if the other+ -- parser finishes later but returns a lot of unconsumed input. Our current+ -- criterion of shortest is whichever parse decided to stop earlier.+ {-# INLINE_LATE step #-}+ step (TeePair (bufL, StepState sL, inpL1, inpL2)+ (bufR, StepState sR, inpR1, inpR2)) x = do+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x+ let next = TeePair l r+ return $ case (stL,stR) of+ (Stp n1, _) ->+ let (_, StepResult rL, _, _) = l+ in Stop n1 rL+ (_, Stp n2) ->+ let (_, StepResult rR, _, _) = r+ in Stop n2 rR+ (Yld n1, Yld n2) -> Yield (min n1 n2) next+ (Err err, _) -> Error err+ (_, Err err) -> Error err+ _ -> Skip 0 next++ step _ _ = undefined++ {-# INLINE_LATE extract #-}+ extract st =+ case st of+ TeePair (_, StepState sL, _, _) _ -> extractL sL+ _ -> error "unreachable"++-- | Longest alternative. Apply both parsers in parallel but choose the result+-- from the one which consumed more input i.e. take the longest succeeding+-- parse.+--+-- /Internal/+--+{-# INLINE longest #-}+longest :: MonadCatch m => Parser m x a -> Parser m x a -> Parser m x a+longest (Parser stepL initialL extractL) (Parser stepR initialR extractR) =+ Parser step initial extract++ where++ {-# INLINE_LATE initial #-}+ initial = do+ sL <- initialL+ sR <- initialR+ return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])++ {-# INLINE consume #-}+ consume buf inp1 inp2 stp st y = do+ let (x, inp11, inp21) =+ case inp1 of+ [] -> (y, [], [])+ z : [] -> (z, reverse (x:inp2), [])+ z : zs -> (z, zs, x:inp2)+ r <- stp st x+ let buf1 = x:buf+ return (buf1, r, inp11, inp21)++ -- consume one input item and return the next state of the fold+ {-# INLINE useStream #-}+ useStream buf inp1 inp2 stp st y = do+ (buf1, r, inp11, inp21) <- consume buf inp1 inp2 stp st y+ case r of+ Yield n s ->+ let state = (Prelude.take n buf1, StepState s, inp11, inp21)+ in assert (n <= length buf1) (return (state, Yld n))+ Stop n b ->+ let state = (Prelude.take n buf1, StepResult b, inp11, inp21)+ in assert (n <= length buf1) (return (state, Stp n))+ -- Skip 0 s -> (buf1, Right s, inp11, inp21)+ Skip n s ->+ let (src0, buf2) = splitAt n buf1+ src = Prelude.reverse src0+ state = (buf2, StepState s, src ++ inp11, inp21)+ in assert (n <= length buf1) (return (state, Skp))+ Error err -> return (undefined, Err err)++ {-# INLINE_LATE step #-}+ step (TeePair (bufL, StepState sL, inpL1, inpL2)+ (bufR, StepState sR, inpR1, inpR2)) x = do+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x+ (r,stR) <- useStream bufR inpR1 inpR2 stepR sR x+ let next = TeePair l r+ return $ case (stL,stR) of+ (Yld n1, Yld n2) -> Yield (min n1 n2) next+ (Yld n1, Stp n2) -> Yield (min n1 n2) next+ (Stp n1, Yld n2) -> Yield (min n1 n2) next+ (Stp n1, Stp n2) ->+ let (_, StepResult rL, _, _) = l+ (_, StepResult rR, _, _) = r+ in Stop (max n1 n2) (if n1 >= n2 then rL else rR)+ (Err err, _) -> Error err+ (_, Err err) -> Error err+ _ -> Skip 0 next++ -- XXX the parser that finishes last may not be the longest because it may+ -- return a lot of unused input which makes it shorter. Our current+ -- criterion of deciding longest is based on whoever decides to finish+ -- last and not whoever consumed more input.+ --+ -- To actually know who made more progress we need to keep an account of+ -- how many items are unconsumed since the last yield.+ --+ step (TeePair (bufL, StepState sL, inpL1, inpL2)+ r@(_, StepResult _, _, _)) x = do+ (l,stL) <- useStream bufL inpL1 inpL2 stepL sL x+ let next = TeePair l r+ return $ case stL of+ Yld n -> Yield n next+ Stp n ->+ let (_, StepResult rL, _, _) = l+ in Stop n rL+ Skp -> Skip 0 next+ Err err -> Error err++ step (TeePair l@(_, StepResult _, _, _)+ (bufR, StepState sR, inpR1, inpR2)) x = do+ (r, stR) <- useStream bufR inpR1 inpR2 stepR sR x+ let next = TeePair l r+ return $ case stR of+ Yld n -> Yield n next+ Stp n ->+ let (_, StepResult rR, _, _) = r+ in Stop n rR+ Skp -> Skip 0 next+ Err err -> Error err++ step _ _ = undefined++ {-# INLINE_LATE extract #-}+ extract st =+ -- XXX When results are partial we may not be able to precisely compare+ -- which parser has made more progress till now. One way to do that is+ -- to figure out the actually consumed input up to the last yield.+ --+ case st of+ TeePair (_, StepState sL, _, _) (_, StepState sR, _, _) -> do+ r <- try $ extractL sL+ case r of+ Left (_ :: ParseError) -> extractR sR+ Right b -> return b+ TeePair (_, StepState sL, _, _) (_, StepResult rR, _, _) -> do+ r <- try $ extractL sL+ case r of+ Left (_ :: ParseError) -> return rR+ Right b -> return b+ TeePair (_, StepResult rL, _, _) (_, StepState sR, _, _) -> do+ r <- try $ extractR sR+ case r of+ Left (_ :: ParseError) -> return rL+ Right b -> return b+ TeePair (_, StepResult _, _, _) (_, StepResult _, _, _) ->+ error "unreachable"
+ src/Streamly/Internal/Data/Parser/Types.hs view
@@ -0,0 +1,634 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Streamly.Parser.Types+-- Copyright : (c) 2020 Composewell Technologies+-- License : BSD3+-- Maintainer : streamly@composewell.com+-- Stability : experimental+-- Portability : GHC+--+-- Streaming and backtracking parsers.+--+-- Parsers just extend folds. Please read the 'Fold' design notes in+-- "Streamly.Internal.Data.Fold.Types" for background on the design.+--+-- = Parser Design+--+-- The 'Parser' type or a parsing fold is a generalization of the 'Fold' type.+-- The 'Fold' type /always/ succeeds on each input. Therefore, it does not need+-- to buffer the input. In contrast, a 'Parser' may fail and backtrack to+-- replay the input again to explore another branch of the parser. Therefore,+-- it needs to buffer the input. Therefore, a 'Parser' is a fold with some+-- additional requirements. To summarize, unlike a 'Fold', a 'Parser':+--+-- 1. may not generate a new value of the accumulator on every input, it may+-- generate a new accumulator only after consuming multiple input elements+-- (e.g. takeEQ).+-- 2. on success may return some unconsumed input (e.g. takeWhile)+-- 3. may fail and return all input without consuming it (e.g. satisfy)+-- 4. backtrack and start inspecting the past input again (e.g. alt)+--+-- These use cases require buffering and replaying of input. To facilitate+-- this, the step function of the 'Fold' is augmented to return the next state+-- of the fold along with a command tag using a 'Step' functor, the tag tells+-- the fold driver to manipulate the future input as the parser wishes. The+-- 'Step' functor provides the following commands to the fold driver+-- corresponding to the use cases outlined in the previous para:+--+-- 1. 'Skip': hold (buffer) the input or go back to a previous position in the stream+-- 2. 'Yield', 'Stop': tell how much input is unconsumed+-- 3. 'Error': indicates that the parser has failed without a result+--+-- = How a Parser Works?+--+-- A parser is just like a fold, it keeps consuming inputs from the stream and+-- accumulating them in an accumulator. The accumulator of the parser could be+-- a singleton value or it could be a collection of values e.g. a list.+--+-- The parser may build a new output value from multiple input items. When it+-- consumes an input item but needs more input to build a complete output item+-- it uses @Skip 0 s@, yielding the intermediate state @s@ and asking the+-- driver to provide more input. When the parser determines that a new output+-- value is complete it can use a @Stop n b@ to terminate the parser with @n@+-- items of input unused and the final value of the accumulator returned as+-- @b@. If at any time the parser determines that the parse has failed it can+-- return @Error err@.+--+-- A parser building a collection of values (e.g. a list) can use the @Yield@+-- constructor whenever a new item in the output collection is generated. If a+-- parser building a collection of values has yielded at least one value then+-- it considered successful and cannot fail after that. In the current+-- implementation, this is not automatically enforced, there is a rule that the+-- parser MUST use only @Stop@ for termination after the first @Yield@, it+-- cannot use @Error@. It may be possible to change the implementation so that+-- this rule is not required, but there may be some performance cost to it.+--+-- 'Streamly.Internal.Data.Parser.takeWhile' and+-- 'Streamly.Internal.Data.Parser.some' combinators are good examples of+-- efficient implementations using all features of this representation. It is+-- possible to idiomatically build a collection of parsed items using a+-- singleton parser and @Alternative@ instance instead of using a+-- multi-yield parser. However, this implementation is amenable to stream+-- fusion and can therefore be much faster.+--+-- = Error Handling+--+-- When a parser's @step@ function is invoked it may iterminate by either a+-- 'Stop' or an 'Error' return value. In an 'Alternative' composition an error+-- return can make the composed parser backtrack and try another parser.+--+-- If the stream stops before a parser could terminate then we use the+-- @extract@ function of the parser to retrieve the last yielded value of the+-- parser. If the parser has yielded at least one value then @extract@ MUST+-- return a value without throwing an error, otherwise it uses the 'ParseError'+-- exception to throw an error.+--+-- We chose the exception throwing mechanism for @extract@ instead of using an+-- explicit error return via an 'Either' type for keeping the interface simple+-- as most of the time we do not need to catch the error in intermediate+-- layers. Note that we cannot use exception throwing mechanism in @step@+-- function because of performance reasons. 'Error' constructor in that case+-- allows loop fusion and better performance.+--+-- = Future Work+--+-- It may make sense to move "takeWhile" type of parsers, which cannot fail but+-- need some lookahead, to splitting folds. This will allow such combinators+-- to be accepted where we need an unfailing "Fold" type.+--+-- Based on application requirements it should be possible to design even a+-- richer interface to manipulate the input stream/buffer. For example, we+-- could randomly seek into the stream in the forward or reverse directions or+-- we can even seek to the end or from the end or seek from the beginning.+--+-- We can distribute and scan/parse a stream using both folds and parsers and+-- merge the resulting streams using different merge strategies (e.g.+-- interleaving or serial).++module Streamly.Internal.Data.Parser.Types+ (+ Step (..)+ , Parser (..)+ , ParseError (..)++ , yield+ , yieldM+ , splitWith++ , die+ , dieM+ , splitSome+ , splitMany+ , alt+ )+where++import Control.Applicative (Alternative(..))+import Control.Exception (assert, Exception(..))+import Control.Monad (MonadPlus(..))+import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow)++import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Fold (Fold(..), toList)+import Streamly.Internal.Data.Strict (Tuple3'(..))++-- | The return type of a 'Parser' step.+--+-- A parser is driven by a parse driver one step at a time, at any time the+-- driver may @extract@ the result of the parser. The parser may ask the driver+-- to backtrack at any point, therefore, the driver holds the input up to a+-- point of no return in a backtracking buffer. The buffer grows or shrinks+-- based on the return values of the parser step execution.+--+-- When a parser step is executed it generates a new intermediate state of the+-- parse result along with a command to the driver. The command tells the+-- driver whether to keep the input stream for a potential backtracking later+-- on or drop it, and how much to keep. The constructors of 'Step' represent+-- the commands to the driver.+--+-- /Internal/+--+{-# ANN type Step Fuse #-}+data Step s b =+ Yield Int s+ -- ^ @Yield offset state@ indicates that the parser has yielded a new+ -- result which is a point of no return. The result can be extracted+ -- using @extract@. The driver drops the buffer except @offset@ elements+ -- before the current position in stream. The rule is that if a parser+ -- has yielded at least once it cannot return a failure result.++ | Skip Int s+ -- ^ @Skip offset state@ indicates that the parser has consumed the current+ -- input but no new result has been generated. A new @state@ is generated.+ -- However, if we use @extract@ on @state@ it will generate a result from+ -- the previous @Yield@. When @offset@ is non-zero it is a backward offset+ -- from the current position in the stream from which the driver will feed+ -- the next input to the parser. The offset cannot be beyond the latest+ -- point of no return created by @Yield@.++ | Stop Int b+ -- ^ @Stop offset result@ asks the driver to stop driving the parser+ -- because it has reached a fixed point and further input will not change+ -- the result. @offset@ is the count of unused elements which includes the+ -- element on which 'Stop' occurred.+ | Error String+ -- ^ An error makes the parser backtrack to the last checkpoint and try+ -- another alternative.++instance Functor (Step s) where+ {-# INLINE fmap #-}+ fmap _ (Yield n s) = Yield n s+ fmap _ (Skip n s) = Skip n s+ fmap f (Stop n b) = Stop n (f b)+ fmap _ (Error err) = Error err++-- | A parser is a fold that can fail and is represented as @Parser step+-- initial extract@. Before we drive a parser we call the @initial@ action to+-- retrieve the initial state of the fold. The parser driver invokes @step@+-- with the state returned by the previous step and the next input element. It+-- results into a new state and a command to the driver represented by 'Step'+-- type. The driver keeps invoking the step function until it stops or fails.+-- At any point of time the driver can call @extract@ to inspect the result of+-- the fold. It may result in an error or an output value.+--+-- /Internal/+--+data Parser m a b =+ forall s. Parser (s -> a -> m (Step s b)) (m s) (s -> m b)++-- | This exception is used for two purposes:+--+-- * When a parser ultimately fails, the user of the parser is intimated via+-- this exception.+-- * When the "extract" function of a parser needs to throw an error.+--+-- /Internal/+--+newtype ParseError = ParseError String+ deriving Show++instance Exception ParseError where+ displayException (ParseError err) = err++instance Functor m => Functor (Parser m a) where+ {-# INLINE fmap #-}+ fmap f (Parser step1 initial extract) =+ Parser step initial (fmap2 f extract)++ where++ step s b = fmap2 f (step1 s b)+ fmap2 g = fmap (fmap g)++-- This is the dual of stream "yield".+--+-- | A parser that always yields a pure value without consuming any input.+--+-- /Internal/+--+{-# INLINE yield #-}+yield :: Monad m => b -> Parser m a b+yield b = Parser (\_ _ -> pure $ Stop 1 b) -- step+ (pure ()) -- initial+ (\_ -> pure b) -- extract++-- This is the dual of stream "yieldM".+--+-- | A parser that always yields the result of an effectful action without+-- consuming any input.+--+-- /Internal/+--+{-# INLINE yieldM #-}+yieldM :: Monad m => m b -> Parser m a b+yieldM b = Parser (\_ _ -> Stop 1 <$> b) -- step+ (pure ()) -- initial+ (\_ -> b) -- extract++-------------------------------------------------------------------------------+-- Sequential applicative+-------------------------------------------------------------------------------++{-# ANN type SeqParseState Fuse #-}+data SeqParseState sl f sr = SeqParseL sl | SeqParseR f sr++-- Note: this implementation of splitWith is fast because of stream fusion but+-- has quadratic time complexity, because each composition adds a new branch+-- that each subsequent parse's input element has to go through, therefore, it+-- cannot scale to a large number of compositions. After around 100+-- compositions the performance starts dipping rapidly beyond a CPS style+-- unfused implementation.+--+-- | Sequential application. Apply two parsers sequentially to an input stream.+-- The input is provided to the first parser, when it is done the remaining+-- input is provided to the second parser. If both the parsers succeed their+-- outputs are combined using the supplied function. The operation fails if any+-- of the parsers fail.+--+-- This undoes an "append" of two streams, it splits the streams using two+-- parsers and zips the results.+--+-- This implementation is strict in the second argument, therefore, the+-- following will fail:+--+-- >>> S.parse (PR.satisfy (> 0) *> undefined) $ S.fromList [1]+--+-- /Internal/+--+{-# INLINE splitWith #-}+splitWith :: Monad m+ => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+splitWith func (Parser stepL initialL extractL)+ (Parser stepR initialR extractR) =+ Parser step initial extract++ where++ initial = SeqParseL <$> initialL++ -- Note: For the composed parse to terminate, the left parser has to be+ -- a terminating parser returning a Stop at some point.+ step (SeqParseL st) a = do+ r <- stepL st a+ case r of+ -- Note: this leads to buffering even if we are not in an+ -- Alternative composition.+ Yield _ s -> return $ Skip 0 (SeqParseL s)+ Skip n s -> return $ Skip n (SeqParseL s)+ Stop n b -> Skip n <$> (SeqParseR (func b) <$> initialR)+ Error err -> return $ Error err++ step (SeqParseR f st) a = do+ r <- stepR st a+ return $ case r of+ Yield n s -> Yield n (SeqParseR f s)+ Skip n s -> Skip n (SeqParseR f s)+ Stop n b -> Stop n (f b)+ Error err -> Error err++ extract (SeqParseR f sR) = fmap f (extractR sR)+ extract (SeqParseL sL) = do+ rL <- extractL sL+ sR <- initialR+ rR <- extractR sR+ return $ func rL rR++-- | 'Applicative' form of 'splitWith'.+instance Monad m => Applicative (Parser m a) where+ {-# INLINE pure #-}+ pure = yield++ {-# INLINE (<*>) #-}+ (<*>) = splitWith id++-------------------------------------------------------------------------------+-- Sequential Alternative+-------------------------------------------------------------------------------++{-# ANN type AltParseState Fuse #-}+data AltParseState sl sr = AltParseL Int sl | AltParseR sr++-- Note: this implementation of alt is fast because of stream fusion but has+-- quadratic time complexity, because each composition adds a new branch that+-- each subsequent alternative's input element has to go through, therefore, it+-- cannot scale to a large number of compositions+--+-- | Sequential alternative. Apply the input to the first parser and return the+-- result if the parser succeeds. If the first parser fails then backtrack and+-- apply the same input to the second parser and return the result.+--+-- Note: This implementation is not lazy in the second argument. The following+-- will fail:+--+-- >>> S.parse (PR.satisfy (> 0) `PR.alt` undefined) $ S.fromList [1..10]+--+-- /Internal/+--+{-# INLINE alt #-}+alt :: Monad m => Parser m x a -> Parser m x a -> Parser m x a+alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) =+ Parser step initial extract++ where++ initial = AltParseL 0 <$> initialL++ -- Once a parser yields at least one value it cannot fail. This+ -- restriction helps us make backtracking more efficient, as we do not need+ -- to keep the consumed items buffered after a yield. Note that we do not+ -- enforce this and if a misbehaving parser does not honor this then we can+ -- get unexpected results.+ step (AltParseL cnt st) a = do+ r <- stepL st a+ case r of+ Yield n s -> return $ Yield n (AltParseL 0 s)+ Skip n s -> do+ assert (cnt + 1 - n >= 0) (return ())+ return $ Skip n (AltParseL (cnt + 1 - n) s)+ Stop n b -> return $ Stop n b+ Error _ -> do+ rR <- initialR+ return $ Skip (cnt + 1) (AltParseR rR)++ step (AltParseR st) a = do+ r <- stepR st a+ return $ case r of+ Yield n s -> Yield n (AltParseR s)+ Skip n s -> Skip n (AltParseR s)+ Stop n b -> Stop n b+ Error err -> Error err++ extract (AltParseR sR) = extractR sR+ extract (AltParseL _ sL) = extractL sL++-- | See documentation of 'Streamly.Internal.Data.Parser.many'.+--+-- /Internal/+--+{-# INLINE splitMany #-}+splitMany :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c+splitMany (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =+ Parser step initial extract++ where++ initial = do+ ps <- initial1 -- parse state+ fs <- finitial -- fold state+ pure (Tuple3' ps 0 fs)++ {-# INLINE step #-}+ step (Tuple3' st cnt fs) a = do+ r <- step1 st a+ let cnt1 = cnt + 1+ case r of+ Yield _ s -> return $ Skip 0 (Tuple3' s cnt1 fs)+ Skip n s -> do+ assert (cnt1 - n >= 0) (return ())+ return $ Skip n (Tuple3' s (cnt1 - n) fs)+ Stop n b -> do+ s <- initial1+ fs1 <- fstep fs b+ -- XXX we need to yield and backtrack here+ return $ Skip n (Tuple3' s 0 fs1)+ Error _ -> do+ xs <- fextract fs+ return $ Stop cnt1 xs++ -- XXX The "try" may impact performance if this parser is used as a scan+ extract (Tuple3' s _ fs) = do+ r <- try $ extract1 s+ case r of+ Left (_ :: ParseError) -> fextract fs+ Right b -> fstep fs b >>= fextract++-- | See documentation of 'Streamly.Internal.Data.Parser.some'.+--+-- /Internal/+--+{-# INLINE splitSome #-}+splitSome :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c+splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =+ Parser step initial extract++ where++ initial = do+ ps <- initial1 -- parse state+ fs <- finitial -- fold state+ pure (Tuple3' ps 0 (Left fs))++ {-# INLINE step #-}+ step (Tuple3' st _ (Left fs)) a = do+ r <- step1 st a+ case r of+ Yield _ s -> return $ Skip 0 (Tuple3' s undefined (Left fs))+ Skip n s -> return $ Skip n (Tuple3' s undefined (Left fs))+ Stop n b -> do+ s <- initial1+ fs1 <- fstep fs b+ -- XXX this is also a yield point, we will never fail beyond+ -- this point. If we do not yield then if an error occurs after+ -- this then we will backtrack to the previous yield point+ -- instead of this point which is wrong.+ --+ -- so we need a yield with backtrack+ return $ Skip n (Tuple3' s 0 (Right fs1))+ Error err -> return $ Error err+ step (Tuple3' st cnt (Right fs)) a = do+ r <- step1 st a+ let cnt1 = cnt + 1+ case r of+ Yield _ s -> return $ Yield 0 (Tuple3' s cnt1 (Right fs))+ Skip n s -> do+ assert (cnt1 - n >= 0) (return ())+ return $ Skip n (Tuple3' s (cnt1 - n) (Right fs))+ Stop n b -> do+ s <- initial1+ fs1 <- fstep fs b+ -- XXX we need to yield here but also backtrack+ return $ Skip n (Tuple3' s 0 (Right fs1))+ Error _ -> Stop cnt1 <$> fextract fs++ -- XXX The "try" may impact performance if this parser is used as a scan+ extract (Tuple3' s _ (Left fs)) = extract1 s >>= fstep fs >>= fextract+ extract (Tuple3' s _ (Right fs)) = do+ r <- try $ extract1 s+ case r of+ Left (_ :: ParseError) -> fextract fs+ Right b -> fstep fs b >>= fextract++-- This is the dual of "nil".+--+-- | A parser that always fails with an error message without consuming+-- any input.+--+-- /Internal/+--+{-# INLINE die #-}+die :: MonadThrow m => String -> Parser m a b+die err =+ Parser (\_ _ -> pure $ Error err) -- step+ (pure ()) -- initial+ (\_ -> throwM $ ParseError err) -- extract++-- This is the dual of "nilM".+--+-- | A parser that always fails with an effectful error message and without+-- consuming any input.+--+-- /Internal/+--+{-# INLINE dieM #-}+dieM :: MonadThrow m => m String -> Parser m a b+dieM err =+ Parser (\_ _ -> Error <$> err) -- step+ (pure ()) -- initial+ (\_ -> err >>= throwM . ParseError) -- extract++-- Note: The default implementations of "some" and "many" loop infinitely+-- because of the strict pattern match on both the arguments in applicative and+-- alternative. With the direct style parser type we cannot use the mutually+-- recursive definitions of "some" and "many".+--+-- Note: With the direct style parser type, the list in "some" and "many" is+-- accumulated strictly, it cannot be consumed lazily.++-- | 'Alternative' instance using 'alt'.+--+-- Note: The implementation of '<|>' is not lazy in the second+-- argument. The following code will fail:+--+-- >>> S.parse (PR.satisfy (> 0) <|> undefined) $ S.fromList [1..10]+--+instance MonadCatch m => Alternative (Parser m a) where+ {-# INLINE empty #-}+ empty = die "empty"++ {-# INLINE (<|>) #-}+ (<|>) = alt++ {-# INLINE many #-}+ many = splitMany toList++ {-# INLINE some #-}+ some = splitSome toList++{-# ANN type ConcatParseState Fuse #-}+data ConcatParseState sl p = ConcatParseL sl | ConcatParseR p++-- Note: The monad instance has quadratic performance complexity. It works fine+-- for small number of compositions but for a scalable implementation we need a+-- CPS version.++-- | Monad composition can be used for lookbehind parsers, we can make the+-- future parses depend on the previously parsed values.+--+-- If we have to parse "a9" or "9a" but not "99" or "aa" we can use the+-- following parser:+--+-- @+-- backtracking :: MonadCatch m => PR.Parser m Char String+-- backtracking =+-- sequence [PR.satisfy isDigit, PR.satisfy isAlpha]+-- '<|>'+-- sequence [PR.satisfy isAlpha, PR.satisfy isDigit]+-- @+--+-- We know that if the first parse resulted in a digit at the first place then+-- the second parse is going to fail. However, we waste that information and+-- parse the first character again in the second parse only to know that it is+-- not an alphabetic char. By using lookbehind in a 'Monad' composition we can+-- avoid redundant work:+--+-- @+-- data DigitOrAlpha = Digit Char | Alpha Char+--+-- lookbehind :: MonadCatch m => PR.Parser m Char String+-- lookbehind = do+-- x1 \<- Digit '<$>' PR.satisfy isDigit+-- '<|>' Alpha '<$>' PR.satisfy isAlpha+--+-- -- Note: the parse depends on what we parsed already+-- x2 <- case x1 of+-- Digit _ -> PR.satisfy isAlpha+-- Alpha _ -> PR.satisfy isDigit+--+-- return $ case x1 of+-- Digit x -> [x,x2]+-- Alpha x -> [x,x2]+-- @+--+instance Monad m => Monad (Parser m a) where+ {-# INLINE return #-}+ return = pure++ -- (>>=) :: Parser m a b -> (b -> Parser m a c) -> Parser m a c+ {-# INLINE (>>=) #-}+ (Parser stepL initialL extractL) >>= func = Parser step initial extract++ where++ initial = ConcatParseL <$> initialL++ step (ConcatParseL st) a = do+ r <- stepL st a+ return $ case r of+ Yield _ s -> Skip 0 (ConcatParseL s)+ Skip n s -> Skip n (ConcatParseL s)+ Stop n b -> Skip n (ConcatParseR (func b))+ Error err -> Error err++ step (ConcatParseR (Parser stepR initialR extractR)) a = do+ st <- initialR+ r <- stepR st a+ return $ case r of+ Yield n s ->+ Yield n (ConcatParseR (Parser stepR (return s) extractR))+ Skip n s ->+ Skip n (ConcatParseR (Parser stepR (return s) extractR))+ Stop n b -> Stop n b+ Error err -> Error err++ extract (ConcatParseR (Parser _ initialR extractR)) =+ initialR >>= extractR++ extract (ConcatParseL sL) = extractL sL >>= f . func++ where++ f (Parser _ initialR extractR) = initialR >>= extractR++-- | 'mzero' is same as 'empty', it aborts the parser. 'mplus' is same as+-- '<|>', it selects the first succeeding parser.+--+-- /Internal/+--+instance MonadCatch m => MonadPlus (Parser m a) where+ {-# INLINE mzero #-}+ mzero = die "mzero"++ {-# INLINE mplus #-}+ mplus = alt
src/Streamly/Internal/Data/Prim/Array/Types.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -33,82 +32,24 @@ , resizeMutablePrimArray , shrinkMutablePrimArray -- * Element Access- , readPrimArray , writePrimArray , indexPrimArray -- * Freezing and Thawing , unsafeFreezePrimArray- , unsafeThawPrimArray- -- * Block Operations- , copyPrimArray- , copyMutablePrimArray- , copyPrimArrayToPtr- , copyMutablePrimArrayToPtr- , setPrimArray -- * Information- , sameMutablePrimArray- , getSizeofMutablePrimArray- , sizeofMutablePrimArray , sizeofPrimArray- -- * List Conversion- , primArrayToList- , primArrayFromList- , primArrayFromListN -- * Folding , foldrPrimArray- , foldrPrimArray'- , foldlPrimArray , foldlPrimArray'- , foldlPrimArrayM'- -- * Effectful Folding- , traversePrimArray_- , itraversePrimArray_- -- * Map/Create- , mapPrimArray- , imapPrimArray- , generatePrimArray- , replicatePrimArray- , filterPrimArray- , mapMaybePrimArray- -- * Effectful Map/Create- -- $effectfulMapCreate- -- ** Lazy Applicative- , traversePrimArray- , itraversePrimArray- , generatePrimArrayA- , replicatePrimArrayA- , filterPrimArrayA- , mapMaybePrimArrayA- -- ** Strict Primitive Monadic- , traversePrimArrayP- , itraversePrimArrayP- , generatePrimArrayP- , replicatePrimArrayP- , filterPrimArrayP- , mapMaybePrimArrayP ) where import GHC.Exts import Data.Primitive.Types import Data.Primitive.ByteArray (ByteArray(..))-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid (Monoid(..),(<>))-#endif-import Control.Applicative import Control.Monad.Primitive-import Control.Monad.ST-import qualified Data.List as L import qualified Data.Primitive.ByteArray as PB-import qualified Data.Primitive.Types as PT -#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)-import Data.Semigroup (Semigroup)-#endif-#if MIN_VERSION_base(4,9,0)-import qualified Data.Semigroup as SG-#endif- -- | Arrays of unboxed elements. This accepts types like 'Double', 'Char', -- 'Int', and 'Word', as well as their fixed-length variants ('Word8', -- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict@@ -155,84 +96,28 @@ | sameByteArray ba1# ba2# = EQ | otherwise = loop 0 where+ cmp LT _ = LT+ cmp EQ y = y+ cmp GT _ = GT sz1 = PB.sizeofByteArray (ByteArray ba1#) sz2 = PB.sizeofByteArray (ByteArray ba2#) sz = quot (min sz1 sz2) (sizeOf (undefined :: a)) loop !i- | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1)+ | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) `cmp` loop (i+1) | otherwise = compare sz1 sz2 {-# INLINE compare #-} -- | @since 0.6.4.0-instance Prim a => IsList (PrimArray a) where- type Item (PrimArray a) = a- fromList = primArrayFromList- fromListN = primArrayFromListN- toList = primArrayToList---- | @since 0.6.4.0 instance (Show a, Prim a) => Show (PrimArray a) where showsPrec p a = showParen (p > 10) $ showString "fromListN " . shows (sizeofPrimArray a) . showString " " . shows (primArrayToList a) -die :: String -> String -> a-die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem--primArrayFromList :: Prim a => [a] -> PrimArray a-primArrayFromList vs = primArrayFromListN (L.length vs) vs--primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a-primArrayFromListN len vs = runST run where- run :: forall s. ST s (PrimArray a)- run = do- arr <- newPrimArray len- let go :: [a] -> Int -> ST s ()- go [] !ix = if ix == len- then return ()- else die "fromListN" "list length less than specified size"- go (a : as) !ix = if ix < len- then do- writePrimArray arr ix a- go as (ix + 1)- else die "fromListN" "list length greater than specified size"- go vs 0- unsafeFreezePrimArray arr- -- | Convert the primitive array to a list. {-# INLINE primArrayToList #-} primArrayToList :: forall a. Prim a => PrimArray a -> [a] primArrayToList xs = build (\c n -> foldrPrimArray c n xs) -primArrayToByteArray :: PrimArray a -> PB.ByteArray-primArrayToByteArray (PrimArray x) = PB.ByteArray x--byteArrayToPrimArray :: ByteArray -> PrimArray a-byteArrayToPrimArray (PB.ByteArray x) = PrimArray x--#if MIN_VERSION_base(4,9,0)--- | @since 0.6.4.0-instance Semigroup (PrimArray a) where- x <> y = byteArrayToPrimArray (primArrayToByteArray x SG.<> primArrayToByteArray y)- sconcat = byteArrayToPrimArray . SG.sconcat . fmap primArrayToByteArray- stimes i arr = byteArrayToPrimArray (SG.stimes i (primArrayToByteArray arr))-#endif---- | @since 0.6.4.0-instance Monoid (PrimArray a) where- mempty = emptyPrimArray-#if !(MIN_VERSION_base(4,11,0))- mappend x y = byteArrayToPrimArray (mappend (primArrayToByteArray x) (primArrayToByteArray y))-#endif- mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray---- | The empty primitive array.-emptyPrimArray :: PrimArray a-{-# NOINLINE emptyPrimArray #-}-emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of- (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of- (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #)- -- | Create a new mutable primitive array of the given length. The -- underlying memory is left uninitialized. newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a)@@ -276,11 +161,6 @@ shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#) = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a))) -readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a-{-# INLINE readPrimArray #-}-readPrimArray (MutablePrimArray arr#) (I# i#)- = primitive (readByteArray# arr# i#)- -- | Write an element to the given index. writePrimArray :: (Prim a, PrimMonad m)@@ -292,128 +172,6 @@ writePrimArray (MutablePrimArray arr#) (I# i#) x = primitive_ (writeByteArray# arr# i# x) --- | Copy part of a mutable array into another mutable array.--- In the case that the destination and--- source arrays are the same, the regions may overlap.-copyMutablePrimArray :: forall m a.- (PrimMonad m, Prim a)- => MutablePrimArray (PrimState m) a -- ^ destination array- -> Int -- ^ offset into destination array- -> MutablePrimArray (PrimState m) a -- ^ source array- -> Int -- ^ offset into source array- -> Int -- ^ number of elements to copy- -> m ()-{-# INLINE copyMutablePrimArray #-}-copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#)- = primitive_ (copyMutableByteArray#- src#- (soff# *# (sizeOf# (undefined :: a)))- dst#- (doff# *# (sizeOf# (undefined :: a)))- (n# *# (sizeOf# (undefined :: a)))- )---- | Copy part of an array into another mutable array.-copyPrimArray :: forall m a.- (PrimMonad m, Prim a)- => MutablePrimArray (PrimState m) a -- ^ destination array- -> Int -- ^ offset into destination array- -> PrimArray a -- ^ source array- -> Int -- ^ offset into source array- -> Int -- ^ number of elements to copy- -> m ()-{-# INLINE copyPrimArray #-}-copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#)- = primitive_ (copyByteArray#- src#- (soff# *# (sizeOf# (undefined :: a)))- dst#- (doff# *# (sizeOf# (undefined :: a)))- (n# *# (sizeOf# (undefined :: a)))- )---- | Copy a slice of an immutable primitive array to an address.--- The offset and length are given in elements of type @a@.--- This function assumes that the 'Prim' instance of @a@--- agrees with the 'Storable' instance. This function is only--- available when building with GHC 7.8 or newer.-copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)- => Ptr a -- ^ destination pointer- -> PrimArray a -- ^ source array- -> Int -- ^ offset into source array- -> Int -- ^ number of prims to copy- -> m ()-{-# INLINE copyPrimArrayToPtr #-}-copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) =- primitive (\ s# ->- let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s#- in (# s'#, () #))- where siz# = sizeOf# (undefined :: a)---- | Copy a slice of an immutable primitive array to an address.--- The offset and length are given in elements of type @a@.--- This function assumes that the 'Prim' instance of @a@--- agrees with the 'Storable' instance. This function is only--- available when building with GHC 7.8 or newer.-copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)- => Ptr a -- ^ destination pointer- -> MutablePrimArray (PrimState m) a -- ^ source array- -> Int -- ^ offset into source array- -> Int -- ^ number of prims to copy- -> m ()-{-# INLINE copyMutablePrimArrayToPtr #-}-copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) =- primitive (\ s# ->- let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s#- in (# s'#, () #))- where siz# = sizeOf# (undefined :: a)---- | Fill a slice of a mutable primitive array with a value.-setPrimArray- :: (Prim a, PrimMonad m)- => MutablePrimArray (PrimState m) a -- ^ array to fill- -> Int -- ^ offset into array- -> Int -- ^ number of values to fill- -> a -- ^ value to fill with- -> m ()-{-# INLINE setPrimArray #-}-setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x- = primitive_ (PT.setByteArray# dst# doff# sz# x)---- | Get the size of a mutable primitive array in elements. Unlike 'sizeofMutablePrimArray',--- this function ensures sequencing in the presence of resizing.-getSizeofMutablePrimArray :: forall m a. (PrimMonad m, Prim a)- => MutablePrimArray (PrimState m) a -- ^ array- -> m Int-{-# INLINE getSizeofMutablePrimArray #-}-#if __GLASGOW_HASKELL__ >= 801-getSizeofMutablePrimArray (MutablePrimArray arr#)- = primitive (\s# ->- case getSizeofMutableByteArray# arr# s# of- (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #)- )-#else--- On older GHCs, it is not possible to resize a byte array, so--- this provides behavior consistent with the implementation for--- newer GHCs.-getSizeofMutablePrimArray arr- = return (sizeofMutablePrimArray arr)-#endif---- | Size of the mutable primitive array in elements. This function shall not--- be used on primitive arrays that are an argument to or a result of--- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'.-sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int-{-# INLINE sizeofMutablePrimArray #-}-sizeofMutablePrimArray (MutablePrimArray arr#) =- I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a)))---- | Check if the two arrays refer to the same memory block.-sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool-{-# INLINE sameMutablePrimArray #-}-sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#)- = isTrue# (sameMutableByteArray# arr# brr#)- -- | Convert a mutable byte array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezePrimArray@@ -423,14 +181,6 @@ = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) --- | Convert an immutable array to a mutable one without copying. The--- original array should not be used after the conversion.-unsafeThawPrimArray- :: PrimMonad m => PrimArray a -> m (MutablePrimArray (PrimState m) a)-{-# INLINE unsafeThawPrimArray #-}-unsafeThawPrimArray (PrimArray arr#)- = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #))- -- | Read a primitive value from the primitive array. indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a {-# INLINE indexPrimArray #-}@@ -451,24 +201,6 @@ | sz > i = f (indexPrimArray arr i) (go (i+1)) | otherwise = z --- | Strict right-associated fold over the elements of a 'PrimArray'.-{-# INLINE foldrPrimArray' #-}-foldrPrimArray' :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b-foldrPrimArray' f z0 arr = go (sizeofPrimArray arr - 1) z0- where- go !i !acc- | i < 0 = acc- | otherwise = go (i - 1) (f (indexPrimArray arr i) acc)---- | Lazy left-associated fold over the elements of a 'PrimArray'.-{-# INLINE foldlPrimArray #-}-foldlPrimArray :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b-foldlPrimArray f z arr = go (sizeofPrimArray arr - 1)- where- go !i- | i < 0 = z- | otherwise = f (go (i - 1)) (indexPrimArray arr i)- -- | Strict left-associated fold over the elements of a 'PrimArray'. {-# INLINE foldlPrimArray' #-} foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b@@ -478,466 +210,3 @@ go !i !acc | i < sz = go (i + 1) (f acc (indexPrimArray arr i)) | otherwise = acc---- | Strict left-associated fold over the elements of a 'PrimArray'.-{-# INLINE foldlPrimArrayM' #-}-foldlPrimArrayM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> PrimArray a -> m b-foldlPrimArrayM' f z0 arr = go 0 z0- where- !sz = sizeofPrimArray arr- go !i !acc1- | i < sz = do- acc2 <- f acc1 (indexPrimArray arr i)- go (i + 1) acc2- | otherwise = return acc1---- | Traverse a primitive array. The traversal forces the resulting values and--- writes them to the new primitive array as it performs the monadic effects.--- Consequently:------ >>> traversePrimArrayP (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int])--- 1--- 2--- *** Exception: Prelude.undefined------ In many situations, 'traversePrimArrayP' can replace 'traversePrimArray',--- changing the strictness characteristics of the traversal but typically improving--- the performance. Consider the following short-circuiting traversal:------ > incrPositiveA :: PrimArray Int -> Maybe (PrimArray Int)--- > incrPositiveA xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs------ This can be rewritten using 'traversePrimArrayP'. To do this, we must--- change the traversal context to @MaybeT (ST s)@, which has a 'PrimMonad'--- instance:------ > incrPositiveB :: PrimArray Int -> Maybe (PrimArray Int)--- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP--- > (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0))--- > xs------ Benchmarks demonstrate that the second implementation runs 150 times--- faster than the first. It also results in fewer allocations.-{-# INLINE traversePrimArrayP #-}-traversePrimArrayP :: (PrimMonad m, Prim a, Prim b)- => (a -> m b)- -> PrimArray a- -> m (PrimArray b)-traversePrimArrayP f arr = do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ix = if ix < sz- then do- b <- f (indexPrimArray arr ix)- writePrimArray marr ix b- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr---- | Filter the primitive array, keeping the elements for which the monadic--- predicate evaluates true.-{-# INLINE filterPrimArrayP #-}-filterPrimArrayP :: (PrimMonad m, Prim a)- => (a -> m Bool)- -> PrimArray a- -> m (PrimArray a)-filterPrimArrayP f arr = do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ixSrc !ixDst = if ixSrc < sz- then do- let a = indexPrimArray arr ixSrc- b <- f a- if b- then do- writePrimArray marr ixDst a- go (ixSrc + 1) (ixDst + 1)- else go (ixSrc + 1) ixDst- else return ixDst- lenDst <- go 0 0- marr' <- resizeMutablePrimArray marr lenDst- unsafeFreezePrimArray marr'---- | Map over the primitive array, keeping the elements for which the monadic--- predicate provides a 'Just'.-{-# INLINE mapMaybePrimArrayP #-}-mapMaybePrimArrayP :: (PrimMonad m, Prim a, Prim b)- => (a -> m (Maybe b))- -> PrimArray a- -> m (PrimArray b)-mapMaybePrimArrayP f arr = do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ixSrc !ixDst = if ixSrc < sz- then do- let a = indexPrimArray arr ixSrc- mb <- f a- case mb of- Just b -> do- writePrimArray marr ixDst b- go (ixSrc + 1) (ixDst + 1)- Nothing -> go (ixSrc + 1) ixDst- else return ixDst- lenDst <- go 0 0- marr' <- resizeMutablePrimArray marr lenDst- unsafeFreezePrimArray marr'---- | Generate a primitive array by evaluating the monadic generator function--- at each index.-{-# INLINE generatePrimArrayP #-}-generatePrimArrayP :: (PrimMonad m, Prim a)- => Int -- ^ length- -> (Int -> m a) -- ^ generator- -> m (PrimArray a)-generatePrimArrayP sz f = do- marr <- newPrimArray sz- let go !ix = if ix < sz- then do- b <- f ix- writePrimArray marr ix b- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr---- | Execute the monadic action the given number of times and store the--- results in a primitive array.-{-# INLINE replicatePrimArrayP #-}-replicatePrimArrayP :: (PrimMonad m, Prim a)- => Int- -> m a- -> m (PrimArray a)-replicatePrimArrayP sz f = do- marr <- newPrimArray sz- let go !ix = if ix < sz- then do- b <- f- writePrimArray marr ix b- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr----- | Map over the elements of a primitive array.-{-# INLINE mapPrimArray #-}-mapPrimArray :: (Prim a, Prim b)- => (a -> b)- -> PrimArray a- -> PrimArray b-mapPrimArray f arr = runST $ do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ix = if ix < sz- then do- let b = f (indexPrimArray arr ix)- writePrimArray marr ix b- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr---- | Indexed map over the elements of a primitive array.-{-# INLINE imapPrimArray #-}-imapPrimArray :: (Prim a, Prim b)- => (Int -> a -> b)- -> PrimArray a- -> PrimArray b-imapPrimArray f arr = runST $ do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ix = if ix < sz- then do- let b = f ix (indexPrimArray arr ix)- writePrimArray marr ix b- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr---- | Filter elements of a primitive array according to a predicate.-{-# INLINE filterPrimArray #-}-filterPrimArray :: Prim a- => (a -> Bool)- -> PrimArray a- -> PrimArray a-filterPrimArray p arr = runST $ do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ixSrc !ixDst = if ixSrc < sz- then do- let !a = indexPrimArray arr ixSrc- if p a- then do- writePrimArray marr ixDst a- go (ixSrc + 1) (ixDst + 1)- else go (ixSrc + 1) ixDst- else return ixDst- dstLen <- go 0 0- marr' <- resizeMutablePrimArray marr dstLen- unsafeFreezePrimArray marr'---- | Filter the primitive array, keeping the elements for which the monadic--- predicate evaluates true.-filterPrimArrayA ::- (Applicative f, Prim a)- => (a -> f Bool) -- ^ mapping function- -> PrimArray a -- ^ primitive array- -> f (PrimArray a)-filterPrimArrayA f = \ !ary ->- let- !len = sizeofPrimArray ary- go !ixSrc- | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst- | otherwise = let x = indexPrimArray ary ixSrc in- liftA2- (\keep (IxSTA m) -> IxSTA $ \ixDst mary -> if keep- then writePrimArray (MutablePrimArray mary) ixDst x >> m (ixDst + 1) mary- else m ixDst mary- )- (f x)- (go (ixSrc + 1))- in if len == 0- then pure emptyPrimArray- else runIxSTA len <$> go 0---- | Map over the primitive array, keeping the elements for which the applicative--- predicate provides a 'Just'.-mapMaybePrimArrayA ::- (Applicative f, Prim a, Prim b)- => (a -> f (Maybe b)) -- ^ mapping function- -> PrimArray a -- ^ primitive array- -> f (PrimArray b)-mapMaybePrimArrayA f = \ !ary ->- let- !len = sizeofPrimArray ary- go !ixSrc- | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst- | otherwise = let x = indexPrimArray ary ixSrc in- liftA2- (\mb (IxSTA m) -> IxSTA $ \ixDst mary -> case mb of- Just b -> writePrimArray (MutablePrimArray mary) ixDst b >> m (ixDst + 1) mary- Nothing -> m ixDst mary- )- (f x)- (go (ixSrc + 1))- in if len == 0- then pure emptyPrimArray- else runIxSTA len <$> go 0---- | Map over a primitive array, optionally discarding some elements. This--- has the same behavior as @Data.Maybe.mapMaybe@.-{-# INLINE mapMaybePrimArray #-}-mapMaybePrimArray :: (Prim a, Prim b)- => (a -> Maybe b)- -> PrimArray a- -> PrimArray b-mapMaybePrimArray p arr = runST $ do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ixSrc !ixDst = if ixSrc < sz- then do- let !a = indexPrimArray arr ixSrc- case p a of- Just b -> do- writePrimArray marr ixDst b- go (ixSrc + 1) (ixDst + 1)- Nothing -> go (ixSrc + 1) ixDst- else return ixDst- dstLen <- go 0 0- marr' <- resizeMutablePrimArray marr dstLen- unsafeFreezePrimArray marr'----- | Traverse a primitive array. The traversal performs all of the applicative--- effects /before/ forcing the resulting values and writing them to the new--- primitive array. Consequently:------ >>> traversePrimArray (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int])--- 1--- 2--- 3--- *** Exception: Prelude.undefined------ The function 'traversePrimArrayP' always outperforms this function, but it--- requires a 'PrimMonad' constraint, and it forces the values as--- it performs the effects.-traversePrimArray ::- (Applicative f, Prim a, Prim b)- => (a -> f b) -- ^ mapping function- -> PrimArray a -- ^ primitive array- -> f (PrimArray b)-traversePrimArray f = \ !ary ->- let- !len = sizeofPrimArray ary- go !i- | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)- | x <- indexPrimArray ary i- = liftA2 (\b (STA m) -> STA $ \mary ->- writePrimArray (MutablePrimArray mary) i b >> m mary)- (f x) (go (i + 1))- in if len == 0- then pure emptyPrimArray- else runSTA len <$> go 0---- | Traverse a primitive array with the index of each element.-itraversePrimArray ::- (Applicative f, Prim a, Prim b)- => (Int -> a -> f b)- -> PrimArray a- -> f (PrimArray b)-itraversePrimArray f = \ !ary ->- let- !len = sizeofPrimArray ary- go !i- | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)- | x <- indexPrimArray ary i- = liftA2 (\b (STA m) -> STA $ \mary ->- writePrimArray (MutablePrimArray mary) i b >> m mary)- (f i x) (go (i + 1))- in if len == 0- then pure emptyPrimArray- else runSTA len <$> go 0---- | Traverse a primitive array with the indices. The traversal forces the--- resulting values and writes them to the new primitive array as it performs--- the monadic effects.-{-# INLINE itraversePrimArrayP #-}-itraversePrimArrayP :: (Prim a, Prim b, PrimMonad m)- => (Int -> a -> m b)- -> PrimArray a- -> m (PrimArray b)-itraversePrimArrayP f arr = do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ix- | ix < sz = do- writePrimArray marr ix =<< f ix (indexPrimArray arr ix)- go (ix + 1)- | otherwise = return ()- go 0- unsafeFreezePrimArray marr---- | Generate a primitive array.-{-# INLINE generatePrimArray #-}-generatePrimArray :: Prim a- => Int -- ^ length- -> (Int -> a) -- ^ element from index- -> PrimArray a-generatePrimArray len f = runST $ do- marr <- newPrimArray len- let go !ix = if ix < len- then do- writePrimArray marr ix (f ix)- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr---- | Create a primitive array by copying the element the given--- number of times.-{-# INLINE replicatePrimArray #-}-replicatePrimArray :: Prim a- => Int -- ^ length- -> a -- ^ element- -> PrimArray a-replicatePrimArray len a = runST $ do- marr <- newPrimArray len- setPrimArray marr 0 len a- unsafeFreezePrimArray marr---- | Generate a primitive array by evaluating the applicative generator--- function at each index.-{-# INLINE generatePrimArrayA #-}-generatePrimArrayA ::- (Applicative f, Prim a)- => Int -- ^ length- -> (Int -> f a) -- ^ element from index- -> f (PrimArray a)-generatePrimArrayA len f =- let- go !i- | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)- | otherwise- = liftA2 (\b (STA m) -> STA $ \mary ->- writePrimArray (MutablePrimArray mary) i b >> m mary)- (f i) (go (i + 1))- in if len == 0- then pure emptyPrimArray- else runSTA len <$> go 0---- | Execute the applicative action the given number of times and store the--- results in a vector.-{-# INLINE replicatePrimArrayA #-}-replicatePrimArrayA ::- (Applicative f, Prim a)- => Int -- ^ length- -> f a -- ^ applicative element producer- -> f (PrimArray a)-replicatePrimArrayA len f =- let- go !i- | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)- | otherwise- = liftA2 (\b (STA m) -> STA $ \mary ->- writePrimArray (MutablePrimArray mary) i b >> m mary)- f (go (i + 1))- in if len == 0- then pure emptyPrimArray- else runSTA len <$> go 0---- | Traverse the primitive array, discarding the results. There--- is no 'PrimMonad' variant of this function since it would not provide--- any performance benefit.-traversePrimArray_ ::- (Applicative f, Prim a)- => (a -> f b)- -> PrimArray a- -> f ()-traversePrimArray_ f a = go 0 where- !sz = sizeofPrimArray a- go !ix = if ix < sz- then f (indexPrimArray a ix) *> go (ix + 1)- else pure ()---- | Traverse the primitive array with the indices, discarding the results.--- There is no 'PrimMonad' variant of this function since it would not--- provide any performance benefit.-itraversePrimArray_ ::- (Applicative f, Prim a)- => (Int -> a -> f b)- -> PrimArray a- -> f ()-itraversePrimArray_ f a = go 0 where- !sz = sizeofPrimArray a- go !ix = if ix < sz- then f ix (indexPrimArray a ix) *> go (ix + 1)- else pure ()--newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int}--runIxSTA :: forall a. Prim a- => Int -- maximum possible size- -> IxSTA a- -> PrimArray a-runIxSTA !szUpper = \ (IxSTA m) -> runST $ do- ar :: MutablePrimArray s a <- newPrimArray szUpper- sz <- m 0 (unMutablePrimArray ar)- ar' <- resizeMutablePrimArray ar sz- unsafeFreezePrimArray ar'-{-# INLINE runIxSTA #-}--newtype STA a = STA {_runSTA :: forall s. MutableByteArray# s -> ST s (PrimArray a)}--runSTA :: forall a. Prim a => Int -> STA a -> PrimArray a-runSTA !sz = \ (STA m) -> runST $ newPrimArray sz >>= \ (ar :: MutablePrimArray s a) -> m (unMutablePrimArray ar)-{-# INLINE runSTA #-}--unMutablePrimArray :: MutablePrimArray s a -> MutableByteArray# s-unMutablePrimArray (MutablePrimArray m) = m--{- $effectfulMapCreate-The naming conventions adopted in this section are explained in the-documentation of the @Data.Primitive@ module.--}
src/Streamly/Internal/Data/Stream/Combinators.hs view
@@ -212,6 +212,9 @@ Nothing -> putStrLn "No SVar" -- | Print debug information about an SVar when the stream ends+--+-- /Internal/+-- inspectMode :: IsStream t => t m a -> t m a inspectMode m = mkStream $ \st stp sng yld -> foldStreamShared (setInspectMode st) stp sng yld m
src/Streamly/Internal/Data/Stream/Parallel.hs view
@@ -226,7 +226,7 @@ -- -- | Like `parallel` but stops the output as soon as the first stream stops. ----- @since 0.7.0+-- /Internal/ {-# INLINE parallelFst #-} parallelFst :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a parallelFst = joinStreamVarPar ParallelVar StopBy@@ -236,7 +236,7 @@ -- | Like `parallel` but stops the output as soon as any of the two streams -- stops. ----- @since 0.7.0+-- /Internal/ {-# INLINE parallelMin #-} parallelMin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a parallelMin = joinStreamVarPar ParallelVar StopAny@@ -364,7 +364,7 @@ -- -- Compare with 'tap'. ----- @since 0.7.0+-- /Internal/ {-# INLINE tapAsync #-} tapAsync :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> t m a tapAsync f m = mkStream $ \st yld sng stp -> do
src/Streamly/Internal/Data/Stream/Prelude.hs view
@@ -38,6 +38,7 @@ , foldlMx' , foldl' , runFold+ , parselMx' -- Lazy left folds are useful only for reversing the stream , foldlS@@ -67,11 +68,13 @@ ) where +import Control.Monad.Catch (MonadThrow) import Control.Monad.Trans (MonadTrans(..)) import Prelude hiding (foldr, minimum, maximum) import qualified Prelude import Streamly.Internal.Data.Fold.Types (Fold (..))+import Streamly.Internal.Data.Parser.Types (Step) #ifdef USE_STREAMK_ONLY import qualified Streamly.Internal.Data.Stream.StreamK as S@@ -156,6 +159,17 @@ foldlMx' :: (IsStream t, Monad m) => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b foldlMx' step begin done m = S.foldlMx' step begin done $ toStreamS m++{-# INLINE parselMx' #-}+parselMx'+ :: (IsStream t, MonadThrow m)+ => (s -> a -> m (Step s b))+ -> m s+ -> (s -> m b)+ -> t m a+ -> m b+parselMx' step initial extract m =+ D.parselMx' step initial extract $ D.toStreamD m -- | Strict left fold with an extraction function. Like the standard strict -- left fold, but applies a user supplied extraction function (the third
src/Streamly/Internal/Data/Stream/SVar.hs view
@@ -42,6 +42,7 @@ import Streamly.Internal.Data.SVar import Streamly.Internal.Data.Stream.StreamK hiding (reverse) +#if __GLASGOW_HASKELL__ < 810 #ifdef INSPECTION import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow)@@ -49,6 +50,7 @@ import Data.Typeable (Typeable) import Test.Inspection (inspect, hasNoTypeClassesExcept) #endif+#endif -- | Pull a stream from an SVar. {-# NOINLINE fromStreamVar #-}@@ -101,6 +103,7 @@ sid <- liftIO $ readIORef (svarStopBy sv) return $ if tid == sid then True else False +#if __GLASGOW_HASKELL__ < 810 #ifdef INSPECTION -- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to -- space leak because the tuple gets allocated in every recursive call and each@@ -117,6 +120,7 @@ , ''Typeable , ''Functor ]+#endif #endif {-# INLINE fromSVar #-}
src/Streamly/Internal/Data/Stream/StreamD.hs view
@@ -128,6 +128,9 @@ , foldlMx' , runFold + , parselMx'+ , splitParse+ -- ** Specialized Folds , tap , tapOffsetEvery@@ -312,6 +315,7 @@ -- * Concurrent Application , mkParallel , mkParallelD+ , newCallbackStream , lastN )@@ -319,14 +323,14 @@ import Control.Concurrent (killThread, myThreadId, takeMVar, threadDelay) import Control.Exception- (Exception, SomeException, AsyncException, fromException)+ (assert, Exception, SomeException, AsyncException, fromException, mask_) import Control.Monad (void, when, forever)-import Control.Monad.Catch (MonadCatch, throwM)+import Control.Monad.Catch (MonadCatch, MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (ReaderT) import Control.Monad.State.Strict (StateT) import Control.Monad.Trans (MonadTrans(lift))-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_) import Data.Bits (shiftR, shiftL, (.|.), (.&.)) import Data.Functor.Identity (Identity(..)) import Data.Int (Int64)@@ -342,13 +346,14 @@ takeWhile, drop, dropWhile, all, any, maximum, minimum, elem, notElem, null, head, tail, zipWith, lookup, foldr1, sequence, (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,- reverse, iterate)+ reverse, iterate, splitAt) import qualified Control.Monad.Catch as MC import qualified Control.Monad.Reader as Reader import qualified Control.Monad.State.Strict as State import qualified Prelude +import Fusion.Plugin.Types (Fuse(..)) import Streamly.Internal.Mutable.Prim.Var (Prim, Var, readVar, newVar, modifyVar') import Streamly.Internal.Data.Time.Units@@ -357,6 +362,7 @@ import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_) import Streamly.Internal.Memory.Array.Types (Array(..)) import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.Parser.Types (Parser(..), ParseError(..)) import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..)) import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) import Streamly.Internal.Data.Time.Units@@ -373,6 +379,7 @@ import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Memory.Ring as RB import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Internal.Data.Parser.Types as PR ------------------------------------------------------------------------------ -- Construction@@ -942,6 +949,178 @@ Stop -> Stop ------------------------------------------------------------------------------+-- Parses+------------------------------------------------------------------------------++-- Inlined definition. Without the inline "serially/parser/take" benchmark+-- degrades and splitParse does not fuse. Even using "inline" at the callsite+-- does not help.+{-# INLINE splitAt #-}+splitAt :: Int -> [a] -> ([a],[a])+splitAt n ls+ | n <= 0 = ([], ls)+ | otherwise = splitAt' n ls+ where+ splitAt' :: Int -> [a] -> ([a], [a])+ splitAt' _ [] = ([], [])+ splitAt' 1 (x:xs) = ([x], xs)+ splitAt' m (x:xs) = (x:xs', xs'')+ where+ (xs', xs'') = splitAt' (m - 1) xs++-- | Run a 'Parse' over a stream.+{-# INLINE_NORMAL parselMx' #-}+parselMx'+ :: MonadThrow m+ => (s -> a -> m (PR.Step s b))+ -> m s+ -> (s -> m b)+ -> Stream m a+ -> m b+parselMx' pstep initial extract (Stream step state) = do+ initial >>= go SPEC state []++ where++ -- XXX currently we are using a dumb list based approach for backtracking+ -- buffer. This can be replaced by a sliding/ring buffer using Data.Array.+ -- That will allow us more efficient random back and forth movement.+ {-# INLINE go #-}+ go !_ st buf !pst = do+ r <- step defState st+ case r of+ Yield x s -> do+ pRes <- pstep pst x+ case pRes of+ -- PR.Yield 0 pst1 -> go SPEC s [] pst1+ PR.Yield n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ go SPEC s (Prelude.take n (x:buf)) pst1+ PR.Skip 0 pst1 -> go SPEC s (x:buf) pst1+ PR.Skip n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ let (src0, buf1) = splitAt n (x:buf)+ src = Prelude.reverse src0+ gobuf SPEC s buf1 src pst1+ PR.Stop _ b -> return b+ PR.Error err -> throwM $ ParseError err+ Skip s -> go SPEC s buf pst+ Stop -> extract pst++ gobuf !_ s buf [] !pst = go SPEC s buf pst+ gobuf !_ s buf (x:xs) !pst = do+ pRes <- pstep pst x+ case pRes of+ -- PR.Yield 0 pst1 -> go SPEC s [] pst1+ PR.Yield n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ gobuf SPEC s (Prelude.take n (x:buf)) xs pst1+ PR.Skip 0 pst1 -> gobuf SPEC s (x:buf) xs pst1+ PR.Skip n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ let (src0, buf1) = splitAt n (x:buf)+ src = Prelude.reverse src0 ++ xs+ gobuf SPEC s buf1 src pst1+ PR.Stop _ b -> return b+ PR.Error err -> throwM $ ParseError err++------------------------------------------------------------------------------+-- Repeated parsing+------------------------------------------------------------------------------++{-# ANN type ParseChunksState Fuse #-}+data ParseChunksState x inpBuf st pst =+ ParseChunksInit inpBuf st+ | ParseChunksInitLeftOver inpBuf+ | ParseChunksStream st inpBuf pst+ | ParseChunksBuf inpBuf st inpBuf pst+ | ParseChunksYield x (ParseChunksState x inpBuf st pst)++{-# INLINE_NORMAL splitParse #-}+splitParse+ :: MonadThrow m+ => Parser m a b+ -> Stream m a+ -> Stream m b+splitParse (Parser pstep initial extract) (Stream step state) =+ Stream stepOuter (ParseChunksInit [] state)++ where++ {-# INLINE_LATE stepOuter #-}+ -- Buffer is empty, go to stream processing loop+ stepOuter _ (ParseChunksInit [] st) = do+ initial >>= return . Skip . ParseChunksStream st []++ -- Buffer is not empty, go to buffered processing loop+ stepOuter _ (ParseChunksInit src st) = do+ initial >>= return . Skip . ParseChunksBuf src st []++ -- XXX we just discard any leftover input at the end+ stepOuter _ (ParseChunksInitLeftOver _) = return Stop++ -- Buffer is empty process elements from the stream+ stepOuter gst (ParseChunksStream st buf pst) = do+ r <- step (adaptState gst) st+ case r of+ Yield x s -> do+ pRes <- pstep pst x+ case pRes of+ -- PR.Yield 0 pst1 -> go SPEC s [] pst1+ PR.Yield n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ let buf1 = Prelude.take n (x:buf)+ return $ Skip $ ParseChunksStream s buf1 pst1+ -- PR.Skip 0 pst1 ->+ -- return $ Skip $ ParseChunksStream s (x:buf) pst1+ PR.Skip n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ let (src0, buf1) = splitAt n (x:buf)+ src = Prelude.reverse src0+ return $ Skip $ ParseChunksBuf src s buf1 pst1+ -- XXX Specialize for Stop 0 common case?+ PR.Stop n b -> do+ assert (n <= length (x:buf)) (return ())+ let src = Prelude.reverse (Prelude.take n (x:buf))+ return $ Skip $+ ParseChunksYield b (ParseChunksInit src s)+ PR.Error err -> throwM $ ParseError err+ Skip s -> return $ Skip $ ParseChunksStream s buf pst+ Stop -> do+ b <- extract pst+ let src = Prelude.reverse buf+ return $ Skip $+ ParseChunksYield b (ParseChunksInitLeftOver src)++ -- go back to stream processing mode+ stepOuter _ (ParseChunksBuf [] s buf pst) =+ return $ Skip $ ParseChunksStream s buf pst++ -- buffered processing loop+ stepOuter _ (ParseChunksBuf (x:xs) s buf pst) = do+ pRes <- pstep pst x+ case pRes of+ -- PR.Yield 0 pst1 ->+ PR.Yield n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ let buf1 = Prelude.take n (x:buf)+ return $ Skip $ ParseChunksBuf xs s buf1 pst1+ -- PR.Skip 0 pst1 -> return $ Skip $ ParseChunksBuf xs s (x:buf) pst1+ PR.Skip n pst1 -> do+ assert (n <= length (x:buf)) (return ())+ let (src0, buf1) = splitAt n (x:buf)+ src = Prelude.reverse src0 ++ xs+ return $ Skip $ ParseChunksBuf src s buf1 pst1+ -- XXX Specialize for Stop 0 common case?+ PR.Stop n b -> do+ assert (n <= length (x:buf)) (return ())+ let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs+ return $ Skip $ ParseChunksYield b (ParseChunksInit src s)+ PR.Error err -> throwM $ ParseError err++ stepOuter _ (ParseChunksYield a next) = return $ Yield a next++------------------------------------------------------------------------------ -- Specialized Folds ------------------------------------------------------------------------------ @@ -1500,7 +1679,7 @@ -> Fold m a b -> Stream m a -> Stream m b-splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =+splitOn patArr (Fold fstep initial done) (Stream step state) = Stream stepOuter GO_START where@@ -1681,7 +1860,7 @@ -> Fold m a b -> Stream m a -> Stream m b-splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)+splitSuffixOn withSep patArr (Fold fstep initial done) (Stream step state) = Stream stepOuter GO_START @@ -2950,8 +3129,14 @@ -- weak pointer to us. {-# INLINE_LATE step #-} step _ GBracketIOInit = do- r <- bef- ref <- newFinalizedIORef (aft r)+ -- We mask asynchronous exceptions to make the execution+ -- of 'bef' and the registration of 'aft' atomic.+ -- A similar thing is done in the resourcet package: https://git.io/JvKV3+ -- Tutorial: https://markkarpov.com/tutorial/exceptions.html+ (r, ref) <- liftBaseOp_ mask_ $ do+ r <- bef+ ref <- newFinalizedIORef (aft r)+ return (r, ref) return $ Skip $ GBracketIONormal (fnormal r) r ref step gst (GBracketIONormal (UnStream step1 st) v ref) = do@@ -4061,6 +4246,30 @@ mkParallel :: (K.IsStream t, MonadAsync m) => t m a -> t m a mkParallel = fromStreamD . mkParallelD . toStreamD +-- Note: we can use another API with two callbacks stop and yield if we want+-- the callback to be able to indicate end of stream.+--+-- | Generates a callback and a stream pair. The callback returned is used to+-- queue values to the stream. The stream is infinite, there is no way for the+-- callback to indicate that it is done now.+--+-- /Internal/+--+{-# INLINE_NORMAL newCallbackStream #-}+newCallbackStream :: (K.IsStream t, MonadAsync m) => m ((a -> m ()), t m a)+newCallbackStream = do+ sv <- newParallelVar StopNone defState++ -- XXX Add our own thread-id to the SVar as we can not know the callback's+ -- thread-id and the callback is not run in a managed worker. We need to+ -- handle this better.+ liftIO myThreadId >>= modifyThread sv++ let callback a = liftIO $ void $ send sv (ChildYield a)+ -- XXX we can return an SVar and then the consumer can unfold from the+ -- SVar?+ return (callback, fromStreamD (fromSVar sv))+ ------------------------------------------------------------------------------- -- Concurrent tap -------------------------------------------------------------------------------@@ -4136,19 +4345,21 @@ -- | Take last 'n' elements from the stream and discard the rest. {-# INLINE lastN #-} lastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a)-lastN n = Fold step initial done- where- step (Tuple3' rb rh i) a = do- rh1 <- liftIO $ RB.unsafeInsert rb rh a- return $ Tuple3' rb rh1 (i + 1)- initial = fmap (\(a, b) -> Tuple3' a b (0 :: Int)) $ liftIO $ RB.new n- done (Tuple3' rb rh i) = do- arr <- liftIO $ A.newArray n- foldFunc i rh snoc' arr rb- snoc' b a = liftIO $ A.unsafeSnoc b a- foldFunc i- | i < n = RB.unsafeFoldRingM- | otherwise = RB.unsafeFoldRingFullM+lastN n+ | n <= 0 = fmap (const mempty) FL.drain+ | otherwise = Fold step initial done+ where+ step (Tuple3' rb rh i) a = do+ rh1 <- liftIO $ RB.unsafeInsert rb rh a+ return $ Tuple3' rb rh1 (i + 1)+ initial = fmap (\(a, b) -> Tuple3' a b (0 :: Int)) $ liftIO $ RB.new n+ done (Tuple3' rb rh i) = do+ arr <- liftIO $ A.newArray n+ foldFunc i rh snoc' arr rb+ snoc' b a = liftIO $ A.unsafeSnoc b a+ foldFunc i+ | i < n = RB.unsafeFoldRingM+ | otherwise = RB.unsafeFoldRingFullM ------------------------------------------------------------------------------ -- Time related
src/Streamly/Internal/Data/Stream/StreamK.hs view
@@ -549,6 +549,8 @@ -- -- Note that the function `f` must be lazy in its argument, that's why we use -- 'unsafeInterleaveIO' because IO monad is strict.+--+-- /Internal/ mfix :: (IsStream t, Monad m) => (m a -> t m a) -> t m a mfix f = mkStream $ \st yld sng stp ->
src/Streamly/Internal/Data/Stream/StreamK/Type.hs view
@@ -276,7 +276,8 @@ fromStopK :: IsStream t => StopK m -> t m a fromStopK k = mkStream $ \_ _ _ stp -> k stp --- | Make a singleton stream from a yield function.+-- | Make a singleton stream from a callback function. The callback function+-- calls the one-shot yield continuation to yield an element. fromYieldK :: IsStream t => YieldK m a -> t m a fromYieldK k = mkStream $ \_ _ sng _ -> k sng
src/Streamly/Internal/Data/Time/Clock.hsc view
@@ -27,12 +27,12 @@ #if __GHCJS__ #define HS_CLOCK_GHCJS 1+#elif defined(_WIN32)+#define HS_CLOCK_WINDOWS 1 #elif (defined (HAVE_TIME_H) && defined(HAVE_CLOCK_GETTIME)) #define HS_CLOCK_POSIX 1 #elif __APPLE__ #define HS_CLOCK_OSX 1-#elif defined(_WIN32)-#define HS_CLOCK_WINDOWS 1 #else #error "Time/Clock functionality not implemented for this system" #endif@@ -299,11 +299,14 @@ -- XXX perform error checks inside c implementation foreign import ccall clock_gettime_win32_monotonic :: Ptr TimeSpec -> IO ()+foreign import ccall clock_gettime_win32_realtime :: Ptr TimeSpec -> IO ()+foreign import ccall clock_gettime_win32_processtime :: Ptr TimeSpec -> IO ()+foreign import ccall clock_gettime_win32_threadtime :: Ptr TimeSpec -> IO () {-# INLINABLE getTime #-} getTime :: Clock -> IO AbsTime getTime Monotonic = getTimeWith $ clock_gettime_win32_monotonic-getTime RealTime = getTimeWith $ clock_gettime_win32_realtime+getTime Realtime = getTimeWith $ clock_gettime_win32_realtime getTime ProcessCPUTime = getTimeWith $ clock_gettime_win32_processtime getTime ThreadCPUTime = getTimeWith $ clock_gettime_win32_threadtime #endif
src/Streamly/Internal/Data/Time/config.h.in view
@@ -1,4 +1,4 @@-/* src/Streamly.Internal.Data.Time/config.h.in. Generated from configure.ac by autoheader. */+/* src/Streamly/Internal/Data/Time/config.h.in. Generated from configure.ac by autoheader. */ /* Define to 1 if you have the `clock_gettime' function. */ #undef HAVE_CLOCK_GETTIME
src/Streamly/Internal/Data/Unfold.hs view
@@ -82,6 +82,7 @@ , nilM , consM , effect+ , singletonM , singleton , identity , const@@ -105,6 +106,11 @@ , filter , filterM + -- * Zipping+ , zipWithM+ , zipWith+ , teeZipWith+ -- * Nesting , concat , concatMapM@@ -125,13 +131,15 @@ ) where -import Control.Exception (Exception)+import Control.Exception (Exception, mask_) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_) import Data.Void (Void) import GHC.Types (SPEC(..))-import Prelude hiding (concat, map, mapM, takeWhile, take, filter, const)+import Prelude+ hiding (concat, map, mapM, takeWhile, take, filter, const, zipWith) +import Fusion.Plugin.Types (Fuse(..)) import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..)) #if __GLASGOW_HASKELL__ < 800 import Streamly.Internal.Data.Stream.StreamD.Type (pattern Stream)@@ -153,6 +161,10 @@ -- | Map a function on the input argument of the 'Unfold'. --+-- @+-- lmap f = concat (singleton f)+-- @+-- -- /Internal/ {-# INLINE_NORMAL lmap #-} lmap :: (a -> c) -> Unfold m c b -> Unfold m a b@@ -160,11 +172,18 @@ -- | Map an action on the input argument of the 'Unfold'. --+-- @+-- lmapM f = concat (singletonM f)+-- @+-- -- /Internal/ {-# INLINE_NORMAL lmapM #-} lmapM :: Monad m => (a -> m c) -> Unfold m c b -> Unfold m a b lmapM f (Unfold ustep uinject) = Unfold ustep (\x -> f x >>= uinject) +-- XXX change the signature to the following?+-- supply :: a -> Unfold m a b -> Unfold m Void b+-- -- | Supply the seed to an unfold closing the input end of the unfold. -- -- /Internal/@@ -173,6 +192,9 @@ supply :: Unfold m a b -> a -> Unfold m Void b supply unf a = lmap (Prelude.const a) unf +-- XXX change the signature to the following?+-- supplyFirst :: a -> Unfold m (a, b) c -> Unfold m b c+-- -- | Supply the first component of the tuple to an unfold that accepts a tuple -- as a seed resulting in a fold that accepts the second component of the tuple -- as a seed.@@ -183,6 +205,9 @@ supplyFirst :: Unfold m (a, b) c -> a -> Unfold m b c supplyFirst unf a = lmap (a, ) unf +-- XXX change the signature to the following?+-- supplySecond :: b -> Unfold m (a, b) c -> Unfold m a c+-- -- | Supply the second component of the tuple to an unfold that accepts a tuple -- as a seed resulting in a fold that accepts the first component of the tuple -- as a seed.@@ -371,25 +396,33 @@ step True = eff >>= \r -> return $ Yield r False step False = return Stop +-- XXX change it to yieldM or change yieldM in Prelude to singletonM+-- -- | Lift a monadic function into an unfold generating a singleton stream. ---{-# INLINE singleton #-}-singleton :: Monad m => (a -> m b) -> Unfold m a b-singleton f = Unfold step inject+{-# INLINE singletonM #-}+singletonM :: Monad m => (a -> m b) -> Unfold m a b+singletonM f = Unfold step inject where inject x = return $ Just x {-# INLINE_LATE step #-} step (Just x) = f x >>= \r -> return $ Yield r Nothing step Nothing = return Stop +-- | Lift a pure function into an unfold generating a singleton stream.+--+{-# INLINE singleton #-}+singleton :: Monad m => (a -> b) -> Unfold m a b+singleton f = singletonM $ return . f+ -- | Identity unfold. Generates a singleton stream with the seed as the only -- element in the stream. ----- > identity = singleton return+-- > identity = singletonM return -- {-# INLINE identity #-} identity :: Monad m => Unfold m a a-identity = singleton return+identity = singletonM return const :: Monad m => m b -> Unfold m a b const m = Unfold step inject@@ -521,11 +554,82 @@ enumerateFromIntegral = enumerateFromToIntegral maxBound -------------------------------------------------------------------------------+-- Zipping+-------------------------------------------------------------------------------++{-# INLINE_NORMAL zipWithM #-}+zipWithM :: Monad m+ => (a -> b -> m c) -> Unfold m x a -> Unfold m y b -> Unfold m (x, y) c+zipWithM f (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject++ where++ inject (x, y) = do+ s1 <- inject1 x+ s2 <- inject2 y+ return (s1, s2, Nothing)++ {-# INLINE_LATE step #-}+ step (s1, s2, Nothing) = do+ r <- step1 s1+ return $+ case r of+ Yield x s -> Skip (s, s2, Just x)+ Skip s -> Skip (s, s2, Nothing)+ Stop -> Stop++ step (s1, s2, Just x) = do+ r <- step2 s2+ case r of+ Yield y s -> do+ z <- f x y+ return $ Yield z (s1, s, Nothing)+ Skip s -> return $ Skip (s1, s, Just x)+ Stop -> return Stop++-- | Divide the input into two unfolds and then zip the outputs to a single+-- stream.+--+-- @+-- S.mapM_ print+-- $ S.concatUnfold (UF.zipWith (,) UF.identity (UF.singleton sqrt))+-- $ S.map (\x -> (x,x))+-- $ S.fromList [1..10]+-- @+--+-- /Internal/+--+{-# INLINE zipWith #-}+zipWith :: Monad m+ => (a -> b -> c) -> Unfold m x a -> Unfold m y b -> Unfold m (x, y) c+zipWith f = zipWithM (\a b -> return (f a b))++-- | Distribute the input to two unfolds and then zip the outputs to a single+-- stream.+--+-- @+-- S.mapM_ print $ S.concatUnfold (UF.teeZipWith (,) UF.identity (UF.singleton sqrt)) $ S.fromList [1..10]+-- @+--+-- /Internal/+--+{-# INLINE_NORMAL teeZipWith #-}+teeZipWith :: Monad m+ => (a -> b -> c) -> Unfold m x a -> Unfold m x b -> Unfold m x c+teeZipWith f unf1 unf2 = lmap (\x -> (x,x)) $ zipWith f unf1 unf2++------------------------------------------------------------------------------- -- Nested ------------------------------------------------------------------------------- +{-# ANN type ConcatState Fuse #-} data ConcatState s1 s2 = ConcatOuter s1 | ConcatInner s1 s2 +-- | Apply the second unfold to each output element of the first unfold and+-- flatten the output in a single stream.+--+-- /Internal/+-- {-# INLINE_NORMAL concat #-} concat :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c concat (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject@@ -554,6 +658,9 @@ data OuterProductState s1 s2 sy x y = OuterProductOuter s1 y | OuterProductInner s1 sy s2 x +-- | Create an outer product (vector product or cartesian product) of the+-- output streams of two unfolds.+-- {-# INLINE_NORMAL outerProduct #-} outerProduct :: Monad m => Unfold m a b -> Unfold m c d -> Unfold m (a, c) (b, d)@@ -584,6 +691,9 @@ data ConcatMapState s1 s2 = ConcatMapOuter s1 | ConcatMapInner s1 s2 +-- | Map an unfold generating action to each element of an unfold and+-- flattern the results into a single stream.+-- {-# INLINE_NORMAL concatMapM #-} concatMapM :: Monad m => (b -> m (Unfold m () c)) -> Unfold m a b -> Unfold m a c@@ -680,8 +790,12 @@ where inject x = do- r <- bef x- ref <- D.newFinalizedIORef (aft r)+ -- Mask asynchronous exceptions to make the execution of 'bef' and+ -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'.+ (r, ref) <- liftBaseOp_ mask_ $ do+ r <- bef x+ ref <- D.newFinalizedIORef (aft r)+ return (r, ref) s <- inject1 r return $ Right (s, r, ref) @@ -930,9 +1044,13 @@ where inject x = do- r <- bef x+ -- Mask asynchronous exceptions to make the execution of 'bef' and+ -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'.+ (r, ref) <- liftBaseOp_ mask_ $ do+ r <- bef x+ ref <- D.newFinalizedIORef (aft r)+ return (r, ref) s <- inject1 r- ref <- D.newFinalizedIORef (aft r) return (s, ref) {-# INLINE_LATE step #-}
src/Streamly/Internal/Data/Unicode/Char.hs view
@@ -11,6 +11,9 @@ -- module Streamly.Internal.Data.Unicode.Char (+ -- * Predicates+ isAsciiAlpha+ -- * Unicode aware operations {- toCaseFold@@ -21,7 +24,21 @@ ) where +import Data.Char (isAsciiUpper, isAsciiLower)+ -- import Streamly (IsStream)++-------------------------------------------------------------------------------+-- Unicode aware operations on strings+-------------------------------------------------------------------------------++-- | Select alphabetic characters in the ascii character set.+--+-- /Internal/+--+{-# INLINE isAsciiAlpha #-}+isAsciiAlpha :: Char -> Bool+isAsciiAlpha c = isAsciiUpper c || isAsciiLower c ------------------------------------------------------------------------------- -- Unicode aware operations on strings
src/Streamly/Internal/FileSystem/Dir.hs view
@@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UnboxedTuples #-} #include "inline.hs"
src/Streamly/Internal/FileSystem/File.hs view
@@ -1,9 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" @@ -180,14 +176,14 @@ -- @since 0.7.0 {-# INLINABLE writeArray #-} writeArray :: Storable a => FilePath -> Array a -> IO ()-writeArray file arr = SIO.withFile file WriteMode (\h -> FH.writeArray h arr)+writeArray file arr = SIO.withFile file WriteMode (`FH.writeArray` arr) -- | append an array to a file. -- -- @since 0.7.0 {-# INLINABLE appendArray #-} appendArray :: Storable a => FilePath -> Array a -> IO ()-appendArray file arr = SIO.withFile file AppendMode (\h -> FH.writeArray h arr)+appendArray file arr = SIO.withFile file AppendMode (`FH.writeArray` arr) ------------------------------------------------------------------------------- -- Stream of Arrays IO@@ -353,12 +349,12 @@ initial = do h <- liftIO (openFile path WriteMode) fld <- FL.initialize (FH.writeChunks h)- `MC.onException` (liftIO $ hClose h)+ `MC.onException` liftIO (hClose h) return (fld, h) step (fld, h) x = do- r <- FL.runStep fld x `MC.onException` (liftIO $ hClose h)+ r <- FL.runStep fld x `MC.onException` liftIO (hClose h) return (r, h)- extract ((Fold _ initial1 extract1), h) = do+ extract (Fold _ initial1 extract1, h) = do liftIO $ hClose h initial1 >>= extract1
src/Streamly/Internal/FileSystem/Handle.hs view
@@ -1,9 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" @@ -352,7 +349,7 @@ {-# INLINE fromChunks #-} fromChunks :: (MonadIO m, Storable a) => Handle -> SerialT m (Array a) -> m ()-fromChunks h m = S.mapM_ (liftIO . writeArray h) m+fromChunks h = S.mapM_ (liftIO . writeArray h) -- | Write a stream of chunks to standard output. --
src/Streamly/Internal/Memory/Array.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -129,6 +128,7 @@ ) where +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) -- import Data.Functor.Identity (Identity) import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)@@ -173,7 +173,7 @@ {-# INLINE fromStreamN #-} fromStreamN :: (MonadIO m, Storable a) => Int -> SerialT m a -> m (Array a) fromStreamN n m = do- if n < 0 then error "writeN: negative write count specified" else return ()+ when (n < 0) $ error "writeN: negative write count specified" A.fromStreamDN n $ D.toStreamD m -- | Create an 'Array' from a stream. This is useful when we want to create a@@ -230,7 +230,7 @@ return $ ReadUState (ForeignPtr end contents) (Ptr start) {-# INLINE_LATE step #-}- step (ReadUState fp@(ForeignPtr end _) p) | p == (Ptr end) =+ step (ReadUState fp@(ForeignPtr end _) p) | p == Ptr end = let x = A.unsafeInlineIO $ touchForeignPtr fp in x `seq` return D.Stop step (ReadUState fp p) = do@@ -242,7 +242,7 @@ -- evaluated/written to before we peek at them. let !x = A.unsafeInlineIO $ peek p return $ D.Yield x- (ReadUState fp (p `plusPtr` (sizeOf (undefined :: a))))+ (ReadUState fp (p `plusPtr` sizeOf (undefined :: a))) -- | Unfold an array into a stream, does not check the end of the array, the -- user is responsible for terminating the stream within the array bounds. For@@ -274,7 +274,7 @@ r <- peek (Ptr p) touch contents return r- let !(Ptr p1) = Ptr p `plusPtr` (sizeOf (undefined :: a))+ let !(Ptr p1) = Ptr p `plusPtr` sizeOf (undefined :: a) return $ D.Yield x (ForeignPtr p1 contents) touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)@@ -402,7 +402,7 @@ if i < 0 || i > length arr - 1 then Nothing else A.unsafeInlineIO $- withForeignPtr (aStart arr) $ \p -> fmap Just $ peekElemOff p i+ withForeignPtr (aStart arr) $ \p -> Just <$> peekElemOff p i {- -- | @readSlice arr i count@ streams a slice of the array @arr@ starting@@ -500,7 +500,7 @@ -- /Internal/ {-# INLINE fold #-} fold :: forall m a b. (MonadIO m, Storable a) => Fold m a b -> Array a -> m b-fold f arr = P.runFold f $ (toStream arr :: Serial.SerialT m a)+fold f arr = P.runFold f (toStream arr :: Serial.SerialT m a) -- | Fold an array using a stream fold operation. --
src/Streamly/Internal/Memory/Array/Types.hs view
@@ -88,7 +88,7 @@ import Control.Exception (assert) import Control.DeepSeq (NFData(..))-import Control.Monad (when)+import Control.Monad (when, void) import Control.Monad.IO.Class (MonadIO(..)) import Data.Functor.Identity (runIdentity) #if __GLASGOW_HASKELL__ < 808@@ -208,7 +208,7 @@ -- XXX we are converting Int to CSize memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()-memcpy dst src len = c_memcpy dst src (fromIntegral len) >> return ()+memcpy dst src len = void (c_memcpy dst src (fromIntegral len)) foreign import ccall unsafe "string.h memcmp" c_memcmp :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt@@ -293,16 +293,16 @@ error "BUG: unsafeSnoc: writing beyond array bounds" poke aEnd x touchForeignPtr aStart- return $ arr {aEnd = aEnd `plusPtr` (sizeOf (undefined :: a))}+ return $ arr {aEnd = aEnd `plusPtr` sizeOf (undefined :: a)} {-# INLINE snoc #-} snoc :: forall a. Storable a => Array a -> a -> IO (Array a)-snoc arr@Array {..} x = do- if (aEnd == aBound)+snoc arr@Array {..} x =+ if aEnd == aBound then do let oldStart = unsafeForeignPtrToPtr aStart size = aEnd `minusPtr` oldStart- newSize = (size + (sizeOf (undefined :: a)))+ newSize = size + sizeOf (undefined :: a) newPtr <- Malloc.mallocForeignPtrAlignedBytes newSize (alignment (undefined :: a)) withForeignPtr newPtr $ \pNew -> do@@ -317,7 +317,7 @@ else do poke aEnd x touchForeignPtr aStart- return $ arr {aEnd = aEnd `plusPtr` (sizeOf (undefined :: a))}+ return $ arr {aEnd = aEnd `plusPtr` sizeOf (undefined :: a)} -- | Reallocate the array to the specified size in bytes. If the size is less -- than the original array the array gets truncated.@@ -449,7 +449,7 @@ r <- peek p touchForeignPtr aStart return r- return $ D.Yield x (p `plusPtr` (sizeOf (undefined :: a)))+ return $ D.Yield x (p `plusPtr` sizeOf (undefined :: a)) {-# INLINE toStreamK #-} toStreamK :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a@@ -466,7 +466,7 @@ r <- peek p touchForeignPtr aStart return r- in x `K.cons` go (p `plusPtr` (sizeOf (undefined :: a)))+ in x `K.cons` go (p `plusPtr` sizeOf (undefined :: a)) {-# INLINE_NORMAL toStreamDRev #-} toStreamDRev :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a@@ -584,7 +584,7 @@ return $ ArrayUnsafe start end step (ArrayUnsafe start end) x = do liftIO $ poke end x- return $ (ArrayUnsafe start (end `plusPtr` sizeOf (undefined :: a)))+ return $ ArrayUnsafe start (end `plusPtr` sizeOf (undefined :: a)) extract (ArrayUnsafe start end) = return $ Array start end end -- liftIO . shrinkToFit -- XXX The realloc based implementation needs to make one extra copy if we use@@ -739,7 +739,7 @@ touchForeignPtr startf return r return $ D.Yield x (InnerLoop st startf- (p `plusPtr` (sizeOf (undefined :: a))) end)+ (p `plusPtr` sizeOf (undefined :: a)) end) {-# INLINE_NORMAL flattenArraysRev #-} flattenArraysRev :: forall m a. (MonadIO m, Storable a)@@ -811,7 +811,7 @@ r <- peek p touchForeignPtr aStart return r- in c x (go (p `plusPtr` (sizeOf (undefined :: a))))+ in c x (go (p `plusPtr` sizeOf (undefined :: a))) -- | Convert an 'Array' into a list. --@@ -842,9 +842,7 @@ instance (Storable a, Read a, Show a) => Read (Array a) where {-# INLINE readPrec #-}- readPrec = do- xs <- readPrec- return (fromList xs)+ readPrec = fromList <$> readPrec readListPrec = readListPrecDefault instance (a ~ Char) => IsString (Array a) where@@ -1037,7 +1035,7 @@ touchForeignPtr startf return r return $ D.Yield x (InnerLoop st startf- (p `plusPtr` (sizeOf (undefined :: a))) end)+ (p `plusPtr` sizeOf (undefined :: a)) end) -- Splice an array into a pre-reserved mutable array. The user must ensure -- that there is enough space in the mutable array.@@ -1048,7 +1046,7 @@ if end `plusPtr` srcLen > bound then error "Bug: spliceIntoUnsafe: Not enough space in the target array" else- withForeignPtr (aStart dst) $ \_ -> do+ withForeignPtr (aStart dst) $ \_ -> withForeignPtr (aStart src) $ \psrc -> do let pdst = aEnd dst memcpy (castPtr pdst) (castPtr psrc) srcLen@@ -1109,7 +1107,7 @@ then D.Skip (SpliceYielding arr (SpliceInitial s)) else D.Skip (SpliceBuffering s arr) D.Skip s -> return $ D.Skip (SpliceInitial s)- D.Stop -> return $ D.Stop+ D.Stop -> return D.Stop step' gst (SpliceBuffering st buf) = do r <- step gst st@@ -1155,7 +1153,7 @@ r <- step1 r1 buf extract1 r - step (Tuple' Nothing r1) arr = do+ step (Tuple' Nothing r1) arr = let len = byteLength arr in if len >= n then do@@ -1222,7 +1220,7 @@ then return $ D.Skip (GatherYielding iov' (GatherInitial s)) else return $ D.Skip (GatherBuffering s iov' len) D.Skip s -> return $ D.Skip (GatherInitial s)- D.Stop -> return $ D.Stop+ D.Stop -> return D.Stop step' gst (GatherBuffering st iov len) = do r <- step (adaptState gst) st@@ -1330,7 +1328,7 @@ Nothing -> D.Skip (Buffering s arr1) Just arr2 -> D.Skip (Yielding arr1 (Splitting s arr2)) D.Skip s -> return $ D.Skip (Initial s)- D.Stop -> return $ D.Stop+ D.Stop -> return D.Stop step' gst (Buffering st buf) = do r <- step gst st@@ -1354,4 +1352,4 @@ Just arr2 -> D.Skip $ Yielding arr1 (Splitting st arr2) step' _ (Yielding arr next) = return $ D.Yield arr next- step' _ Finishing = return $ D.Stop+ step' _ Finishing = return D.Stop
src/Streamly/Internal/Memory/ArrayStream.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} #include "inline.hs"
src/Streamly/Internal/Prelude.hs view
@@ -20,6 +20,11 @@ -- Stability : experimental -- Portability : GHC --+-- This is an Internal module consisting of released, unreleased and+-- unimplemented APIs. For stable and released APIs please see+-- "Streamly.Prelude" module. This module provides documentation only for the+-- unreleased and unimplemented APIs. For documentation on released APIs please+-- see "Streamly.Prelude" module. module Streamly.Internal.Prelude (@@ -61,6 +66,7 @@ , K.fromFoldable , fromFoldableM , fromPrimVar+ , fromCallback -- ** Time related , currentTime@@ -84,6 +90,10 @@ , foldl1' , foldlM' + -- ** Composable Left Folds+ , fold+ , parse+ -- ** Concurrent Folds , foldAsync , (|$.)@@ -97,7 +107,7 @@ , length , sum , product- --, mconcat+ , mconcat -- -- ** To Summary (Maybe) (Full Folds) , maximumBy@@ -106,6 +116,18 @@ , minimum , the + -- ** Lazy Folds+ -- -- ** To Containers (Full Folds)+ , toList+ , toListRev+ , toPure+ , toPureRev++ -- ** Composable Left Folds++ , toStream -- XXX rename to write?+ , toStreamRev -- XXX rename to writeRev?+ -- ** Partial Folds -- -- ** To Elements (Partial Folds)@@ -131,17 +153,24 @@ , and , or - -- ** To Containers- , toList- , toListRev- , toPure- , toPureRev+ -- ** Multi-Stream folds+ -- Full equivalence+ , eqBy+ , cmpBy - -- ** Composable Left Folds- , fold+ -- finding subsequences+ , isPrefixOf+ , isSuffixOf+ , isInfixOf+ , isSubsequenceOf - , toStream -- XXX rename to write?- , toStreamRev -- XXX rename to writeRev?+ -- trimming sequences+ , stripPrefix+ , stripSuffix+ -- , stripInfix+ , dropPrefix+ , dropInfix+ , dropSuffix -- * Transformation , transform@@ -150,7 +179,15 @@ , Serial.map , sequence , mapM++ -- ** Special Maps , mapM_+ , trace+ , tap+ , tapOffsetEvery+ , tapAsync+ , tapRate+ , pollCounts -- ** Scanning -- ** Left scans@@ -167,6 +204,9 @@ , scan , postscan + -- XXX Once we have pipes the contravariant transformations can be+ -- represented by attaching pipes before a transformation.+ -- -- , lscanl' -- , lscanlM' -- , lscanl1'@@ -184,141 +224,92 @@ , (|$) , (|&) - -- ** Indexing- , indexed- , indexedR- -- , timestamped- -- , timestampedR -- timer- -- ** Filtering , filter , filterM - -- ** Stateful Filters- , take- , takeByTime- -- , takeEnd- , takeWhile- , takeWhileM- -- , takeWhileEnd- , drop- , dropByTime- -- , dropEnd- , dropWhile- , dropWhileM- -- , dropWhileEnd- -- , dropAround+ -- ** Mapping Filters+ , mapMaybe+ , mapMaybeM++ -- ** Deleting Elements , deleteBy , uniq -- , uniqBy -- by predicate e.g. to remove duplicate "/" in a path -- , uniqOn -- to remove duplicate sequences -- , pruneBy -- dropAround + uniqBy - like words - -- ** Mapping Filters- , mapMaybe- , mapMaybeM- , rollingMapM- , rollingMap-- -- ** Scanning Filters- , findIndices- , elemIndices- -- , seqIndices -- search a sequence in the stream+ -- ** Inserting Elements - -- ** Insertion , insertBy , intersperseM , intersperse , intersperseSuffix , intersperseSuffixBySpan -- , intersperseBySpan+ -- , intersperseByIndices -- using an index function/stream++ -- time domain intersperse+ -- , intersperseByTime+ -- , intersperseByEvent , interjectSuffix , delayPost + -- ** Indexing+ , indexed+ , indexedR+ -- , timestamped+ -- , timestampedR -- timer+ -- ** Reordering , reverse , reverse' - -- * Multi-Stream Operations-- -- ** Appending- , append-- -- ** Interleaving- , interleave- , interleaveMin- , interleaveSuffix- , interleaveInfix-- , Serial.wSerialFst- , Serial.wSerialMin-- -- ** Scheduling- , roundrobin-- -- ** Parallel- , Par.parallelFst- , Par.parallelMin-- -- ** Merging+ -- ** Parsing+ , splitParse - -- , merge- , mergeBy- , mergeByM- , mergeAsyncBy- , mergeAsyncByM+ -- ** Trimming+ , take+ , takeByTime+ -- , takeEnd+ , takeWhile+ , takeWhileM+ -- , takeWhileEnd+ , drop+ , dropByTime+ -- , dropEnd+ , dropWhile+ , dropWhileM+ -- , dropWhileEnd+ -- , dropAround - -- ** Zipping- , Z.zipWith- , Z.zipWithM- , Z.zipAsyncWith- , Z.zipAsyncWithM+ -- ** Breaking - -- ** Nested Streams- , concatMapM- , concatUnfold- , concatUnfoldInterleave- , concatUnfoldRoundrobin- , concatMap- , concatMapWith- , gintercalate- , gintercalateSuffix- , intercalate- , intercalateSuffix- , interpose- , interposeSuffix- , concatMapIterateWith- , concatMapTreeWith- , concatMapLoopWith- , concatMapTreeYieldLeavesWith+ -- Nary+ , chunksOf+ , chunksOf2+ , arraysOf+ , intervalsOf - -- -- ** Breaking+ -- ** Searching+ -- -- *** Searching Elements+ , findIndices+ , elemIndices - -- By chunks- , splitAt -- spanN- -- , splitIn -- sessionN+ -- -- *** Searching Sequences+ -- , seqIndices -- search a sequence in the stream - -- By elements- , span -- spanWhile- , break -- breakBefore- -- , breakAfter- -- , breakOn- -- , breakAround- , spanBy- , spanByRolling+ -- -- *** Searching Multiple Sequences+ -- , seqIndicesAny -- search any of the given sequence in the stream - -- By sequences- -- , breakOnSeq+ -- -- -- ** Searching Streams+ -- -- | Finding a stream within another stream. -- ** Splitting- -- , groupScan-- -- -- *** Chunks- , chunksOf- , chunksOf2- , arraysOf- , intervalsOf+ -- | Streams can be sliced into segments in space or in time. We use the+ -- term @chunk@ to refer to a spatial length of the stream (spatial window)+ -- and the term @session@ to refer to a length in time (time window). -- -- *** Using Element Separators , splitOn@@ -330,7 +321,7 @@ -- , splitByPrefix , wordsBy -- stripAndCompactBy - -- -- *** Using Sequence Separators+ -- -- *** Splitting By Sequences , splitOnSeq , splitOnSuffixSeq -- , splitOnPrefixSeq@@ -346,36 +337,58 @@ -- , splitOnAnySuffixSeq -- , splitOnAnyPrefixSeq + -- -- *** Splitting By Streams+ -- -- | Splitting a stream using another stream as separator.+ -- Nested splitting , splitInnerBy , splitInnerBySuffix -- ** Grouping+ -- In imperative terms, grouped folding can be considered as a nested loop+ -- where we loop over the stream to group elements and then loop over+ -- individual groups to fold them to a single value that is yielded in the+ -- output stream.++ -- , groupScan+ , groups , groupsBy , groupsByRolling - -- ** Distributing- , trace- , tap- , tapOffsetEvery- , tapAsync- , tapRate- , pollCounts+ -- ** Group map+ , rollingMapM+ , rollingMap -- * Windowed Classification + -- | Split the stream into windows or chunks in space or time. Each window+ -- can be associated with a key, all events associated with a particular+ -- key in the window can be folded to a single result. The stream is split+ -- into windows of specified size, the window can be terminated early if+ -- the closing flag is specified in the input stream.+ --+ -- The term "chunk" is used for a space window and the term "session" is+ -- used for a time window.+ -- ** Tumbling Windows+ -- | A new window starts after the previous window is finished.+ -- , classifyChunksOf , classifySessionsBy , classifySessionsOf -- ** Keep Alive Windows+ -- | The window size is extended if an event arrives within the specified+ -- window size. This can represent sessions with idle or inactive timeout.+ -- , classifyKeepAliveChunks , classifyKeepAliveSessions {- -- ** Sliding Windows+ -- | A new window starts after the specified slide from the previous+ -- window. Therefore windows can overlap. , classifySlidingChunks , classifySlidingSessions -}@@ -383,22 +396,77 @@ -- , slidingChunkBuffer -- , slidingSessionBuffer - -- ** Containers of Streams+ -- * Combining Streams++ -- ** Appending+ , append++ -- ** Interleaving+ , interleave+ , interleaveMin+ , interleaveSuffix+ , interleaveInfix++ , Serial.wSerialFst+ , Serial.wSerialMin++ -- ** Scheduling+ , roundrobin++ -- ** Parallel+ , Par.parallelFst+ , Par.parallelMin++ -- ** Merging++ -- , merge+ , mergeBy+ , mergeByM+ , mergeAsyncBy+ , mergeAsyncByM++ -- ** Zipping+ , Z.zipWith+ , Z.zipWithM+ , Z.zipAsyncWith+ , Z.zipAsyncWithM++ -- ** Folding Containers of Streams , foldWith , foldMapWith , forEachWith - -- ** Folding- , eqBy- , cmpBy- , isPrefixOf- -- , isSuffixOf- -- , isInfixOf- , isSubsequenceOf- , stripPrefix- -- , stripSuffix- -- , stripInfix+ -- Flattening Nested Streams+ -- ** Folding Streams of Streams+ , concat+ , concatM+ , concatMap+ , concatMapM+ -- XXX add stateful concatMapWith?+ , concatMapWith+ -- , bindWith + -- ** Flattening Using Unfolds+ , concatUnfold+ , concatUnfoldInterleave+ , concatUnfoldRoundrobin++ -- ** Feedback Loops+ , concatMapIterateWith+ , concatMapTreeWith+ , concatMapLoopWith+ , concatMapTreeYieldLeavesWith+ , K.mfix++ -- ** Inserting Streams in Streams+ , gintercalate+ , gintercalateSuffix+ , intercalate+ , intercalateSuffix+ , interpose+ , interposeSuffix+ -- , interposeBy+ -- * Exceptions , before , after@@ -416,14 +484,12 @@ -- * Transform Inner Monad , liftInner+ , usingReaderT , runReaderT , evalStateT , usingStateT , runStateT - -- * MonadFix- , K.mfix- -- * Diagnostics , inspectMode @@ -445,7 +511,7 @@ import Control.Concurrent (threadDelay) import Control.Exception (Exception, assert) import Control.Monad (void)-import Control.Monad.Catch (MonadCatch)+import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (ReaderT) import Control.Monad.State.Strict (StateT)@@ -464,7 +530,7 @@ notElem, maximum, minimum, head, last, tail, length, null, reverse, iterate, init, and, or, lookup, foldr1, (!!), scanl, scanl1, replicate, concatMap, span, splitAt, break,- repeat)+ repeat, concat, mconcat) import qualified Data.Heap as H import qualified Data.Map.Strict as Map@@ -473,6 +539,7 @@ import Streamly.Internal.Data.Stream.Enumeration (Enumerable(..), enumerate, enumerateTo) import Streamly.Internal.Data.Fold.Types (Fold (..), Fold2 (..))+import Streamly.Internal.Data.Parser.Types (Parser (..)) import Streamly.Internal.Data.Unfold.Types (Unfold) import Streamly.Internal.Memory.Array.Types (Array, writeNUnsafe) -- import Streamly.Memory.Ring (Ring)@@ -904,6 +971,19 @@ fromPrimVar :: (IsStream t, MonadIO m, Prim a) => Var IO a -> t m a fromPrimVar = fromStreamD . D.fromPrimVar +-- | Takes a callback setter function and provides it with a callback. The+-- callback when invoked adds a value at the tail of the stream. Returns a+-- stream of values generated by the callback.+--+-- /Internal/+--+{-# INLINE fromCallback #-}+fromCallback :: MonadAsync m => ((a -> m ()) -> m ()) -> SerialT m a+fromCallback setCallback = concatM $ do+ (callback, stream) <- D.newCallbackStream+ setCallback callback+ return stream+ ------------------------------------------------------------------------------ -- Time related ------------------------------------------------------------------------------@@ -987,7 +1067,7 @@ -- -- > foldrM f z s = runIdentityT $ foldrS (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s ----- @since 0.7.0+-- /Internal/ {-# INLINE foldrS #-} foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b foldrS = K.foldrS@@ -1002,7 +1082,7 @@ -- 'foldrT' can be used to translate streamly streams to other transformer -- monads e.g. to a different streaming type. ----- @since 0.7.0+-- /Internal/ {-# INLINE foldrT #-} foldrT :: (IsStream t, Monad m, Monad (s m), MonadTrans s) => (a -> s m b -> s m b) -> s m b -> t m a -> s m b@@ -1114,6 +1194,18 @@ -} ------------------------------------------------------------------------------+-- Running a Parse+------------------------------------------------------------------------------++-- | Parse a stream using the supplied 'Parse'.+--+-- /Internal/+--+{-# INLINE parse #-}+parse :: MonadThrow m => Parser m a b -> SerialT m a -> m b+parse (Parser step initial extract) = P.parselMx' step initial extract++------------------------------------------------------------------------------ -- Specialized folds ------------------------------------------------------------------------------ @@ -1298,6 +1390,13 @@ product :: (Monad m, Num a) => SerialT m a -> m a product = foldl' (*) 1 +-- | Fold a stream of monoid elements by appending them.+--+-- /Internal/+{-# INLINE mconcat #-}+mconcat :: (Monad m, Monoid a) => SerialT m a -> m a+mconcat = foldr mappend mempty+ -- | -- @ -- minimum = 'minimumBy' compare@@ -1420,6 +1519,63 @@ isPrefixOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool isPrefixOf m1 m2 = D.isPrefixOf (toStreamD m1) (toStreamD m2) +-- Note: isPrefixOf uses the prefix stream only once. In contrast, isSuffixOf+-- may use the suffix stream many times. To run in optimal memory we do not+-- want to buffer the suffix stream in memory therefore we need an ability to+-- clone (or consume it multiple times) the suffix stream without any side+-- effects so that multiple potential suffix matches can proceed in parallel+-- without buffering the suffix stream. For example, we may create the suffix+-- stream from a file handle, however, if we evaluate the stream multiple+-- times, once for each match, we will need a different file handle each time+-- which may exhaust the file descriptors. Instead, we want to share the same+-- underlying file descriptor, use pread on it to generate the stream and clone+-- the stream for each match. Therefore the suffix stream should be built in+-- such a way that it can be consumed multiple times without any problems.++-- XXX Can be implemented with better space/time complexity.+-- Space: @O(n)@ worst case where @n@ is the length of the suffix.++-- | Returns 'True' if the first stream is a suffix of the second. A stream is+-- considered a suffix of itself.+--+-- @+-- > S.isSuffixOf (S.fromList "hello") (S.fromList "hello" :: SerialT IO Char)+-- True+-- @+--+-- Space: @O(n)@, buffers entire input stream and the suffix.+--+-- /Internal/+--+-- /Suboptimal/ - Help wanted.+--+{-# INLINE isSuffixOf #-}+isSuffixOf :: (Monad m, Eq a) => SerialT m a -> SerialT m a -> m Bool+isSuffixOf suffix stream = isPrefixOf (reverse suffix) (reverse stream)++-- | Returns 'True' if the first stream is an infix of the second. A stream is+-- considered an infix of itself.+--+-- @+-- > S.isInfixOf (S.fromList "hello") (S.fromList "hello" :: SerialT IO Char)+-- True+-- @+--+-- Space: @O(n)@ worst case where @n@ is the length of the infix.+--+-- /Internal/+--+-- /Requires 'Storable' constraint/ - Help wanted.+--+{-# INLINE isInfixOf #-}+isInfixOf :: (MonadIO m, Eq a, Enum a, Storable a)+ => SerialT m a -> SerialT m a -> m Bool+isInfixOf infx stream = do+ arr <- fold A.write infx+ -- XXX can use breakOnSeq instead (when available)+ r <- null $ drop 1 $ splitOnSeq arr FL.drain stream+ return (not r)+ -- | Returns 'True' if all the elements of the first stream occur, in order, in -- the second stream. The elements do not have to occur consecutively. A stream -- is a subsequence of itself.@@ -1434,10 +1590,13 @@ isSubsequenceOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool isSubsequenceOf m1 m2 = D.isSubsequenceOf (toStreamD m1) (toStreamD m2) --- | Drops the given prefix from a stream. Returns 'Nothing' if the stream does--- not start with the given prefix. Returns @Just nil@ when the prefix is the--- same as the stream.+-- | Strip prefix if present and tell whether it was stripped or not. Returns+-- 'Nothing' if the stream does not start with the given prefix, stripped+-- stream otherwise. Returns @Just nil@ when the prefix is the same as the+-- stream. --+-- Space: @O(1)@+-- -- @since 0.6.0 {-# INLINE stripPrefix #-} stripPrefix@@ -1446,6 +1605,62 @@ stripPrefix m1 m2 = fmap fromStreamD <$> D.stripPrefix (toStreamD m1) (toStreamD m2) +-- Note: If we want to return a Maybe value to know whether the+-- suffix/infix was present or not along with the stripped stream then+-- we need to buffer the whole input stream.+--+-- | Drops the given suffix from a stream. Returns 'Nothing' if the stream does+-- not end with the given suffix. Returns @Just nil@ when the suffix is the+-- same as the stream.+--+-- It may be more efficient to convert the stream to an Array and use+-- stripSuffix on that especially if the elements have a Storable or Prim+-- instance.+--+-- Space: @O(n)@, buffers the entire input stream as well as the suffix+--+-- /Internal/+{-# INLINE stripSuffix #-}+stripSuffix+ :: (Monad m, Eq a)+ => SerialT m a -> SerialT m a -> m (Maybe (SerialT m a))+stripSuffix m1 m2 = fmap reverse <$> stripPrefix (reverse m1) (reverse m2)++-- | Drop prefix from the input stream if present.+--+-- Space: @O(1)@+--+-- /Unimplemented/ - Help wanted.+{-# INLINE dropPrefix #-}+dropPrefix ::+ -- (Eq a, IsStream t, Monad m) =>+ t m a -> t m a -> t m a+dropPrefix = error "Not implemented yet!"++-- | Drop all matching infix from the input stream if present. Infix stream+-- may be consumed multiple times.+--+-- Space: @O(n)@ where n is the length of the infix.+--+-- /Unimplemented/ - Help wanted.+{-# INLINE dropInfix #-}+dropInfix ::+ -- (Eq a, IsStream t, Monad m) =>+ t m a -> t m a -> t m a+dropInfix = error "Not implemented yet!"++-- | Drop suffix from the input stream if present. Suffix stream may be+-- consumed multiple times.+--+-- Space: @O(n)@ where n is the length of the suffix.+--+-- /Unimplemented/ - Help wanted.+{-# INLINE dropSuffix #-}+dropSuffix ::+ -- (Eq a, IsStream t, Monad m) =>+ t m a -> t m a -> t m a+dropSuffix = error "Not implemented yet!"+ ------------------------------------------------------------------------------ -- Map and Fold ------------------------------------------------------------------------------@@ -1692,6 +1907,9 @@ ------------------------------------------------------------------------------ -- | Use a 'Pipe' to transform a stream.+--+-- /Internal/+-- {-# INLINE transform #-} transform :: (IsStream t, Monad m) => Pipe m a b -> t m a -> t m b transform pipe xs = fromStreamD $ D.transform pipe (toStreamD xs)@@ -1802,7 +2020,7 @@ -- -- | Like scanl' but does not stream the final value of the accumulator. ----- @since 0.6.0+-- /Internal/ {-# INLINE prescanl' #-} prescanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b prescanl' step z m = fromStreamD $ D.prescanl' step z $ toStreamD m@@ -1810,7 +2028,7 @@ -- XXX this needs to be concurrent -- | Like postscanl' but with a monadic step function. ----- @since 0.6.0+-- /Internal/ {-# INLINE prescanlM' #-} prescanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b prescanlM' step z m = fromStreamD $ D.prescanlM' step z $ toStreamD m@@ -2121,7 +2339,7 @@ -- | Like 'reverse' but several times faster, requires a 'Storable' instance. ----- @since 0.7.0+-- /Internal/ {-# INLINE reverse' #-} reverse' :: (IsStream t, MonadIO m, Storable a) => t m a -> t m a reverse' s = fromStreamD $ D.reverse' $ toStreamD s@@ -2161,7 +2379,7 @@ -- | Insert a monadic action after each element in the stream. ----- @since 0.7.0+-- /Internal/ {-# INLINE intersperseSuffix #-} intersperseSuffix :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a intersperseSuffix m = fromStreamD . D.intersperseSuffix m . toStreamD@@ -2227,7 +2445,7 @@ -- "h,e,l,l,o" -- @ ----- @since 0.7.0+-- /Internal/ {-# INLINE interjectSuffix #-} interjectSuffix :: (IsStream t, MonadAsync m)@@ -2476,6 +2694,17 @@ concatMap ::(IsStream t, Monad m) => (a -> t m b) -> t m a -> t m b concatMap f m = fromStreamD $ D.concatMap (toStreamD . f) (toStreamD m) +-- | Flatten a stream of streams to a single stream.+--+-- @+-- concat = concatMap id+-- @+--+-- /Internal/+{-# INLINE concat #-}+concat :: (IsStream t, Monad m) => t m (t m a) -> t m a+concat = concatMap id+ -- | Append the outputs of two streams, yielding all the elements from the -- first stream and then yielding all the elements from the second stream. --@@ -2486,7 +2715,7 @@ -- but use 'concatMap' or 'concatMapWith serial' for appending @n@ streams or -- infinite containers of streams. ----- @since 0.7.0+-- /Internal/ {-# INLINE append #-} append ::(IsStream t, Monad m) => t m b -> t m b -> t m b append m1 m2 = fromStreamD $ D.append (toStreamD m1) (toStreamD m2)@@ -2513,7 +2742,7 @@ -- -- Do not use at scale in concatMapWith. ----- @since 0.7.0+-- /Internal/ {-# INLINE interleave #-} interleave ::(IsStream t, Monad m) => t m b -> t m b -> t m b interleave m1 m2 = fromStreamD $ D.interleave (toStreamD m1) (toStreamD m2)@@ -2535,7 +2764,7 @@ -- -- Do not use at scale in concatMapWith. ----- @since 0.7.0+-- /Internal/ {-# INLINE interleaveSuffix #-} interleaveSuffix ::(IsStream t, Monad m) => t m b -> t m b -> t m b interleaveSuffix m1 m2 =@@ -2558,7 +2787,7 @@ -- -- Do not use at scale in concatMapWith. ----- @since 0.7.0+-- /Internal/ {-# INLINE interleaveInfix #-} interleaveInfix ::(IsStream t, Monad m) => t m b -> t m b -> t m b interleaveInfix m1 m2 =@@ -2580,7 +2809,7 @@ -- -- Do not use at scale in concatMapWith. ----- @since 0.7.0+-- /Internal/ {-# INLINE interleaveMin #-} interleaveMin ::(IsStream t, Monad m) => t m b -> t m b -> t m b interleaveMin m1 m2 = fromStreamD $ D.interleaveMin (toStreamD m1) (toStreamD m2)@@ -2596,7 +2825,7 @@ -- -- Do not use at scale in concatMapWith. ----- @since 0.7.0+-- /Internal/ {-# INLINE roundrobin #-} roundrobin ::(IsStream t, Monad m) => t m b -> t m b -> t m b roundrobin m1 m2 = fromStreamD $ D.roundRobin (toStreamD m1) (toStreamD m2)@@ -2611,6 +2840,17 @@ concatMapM :: (IsStream t, Monad m) => (a -> m (t m b)) -> t m a -> t m b concatMapM f m = fromStreamD $ D.concatMapM (fmap toStreamD . f) (toStreamD m) +-- | Given a stream value in the underlying monad, lift and join the underlying+-- monad with the stream monad.+--+-- Compare with 'concat' and 'sequence'.+--+-- /Internal/+--+{-# INLINE concatM #-}+concatM :: (IsStream t, Monad m) => m (t m a) -> t m a+concatM generator = concatMapM (\() -> generator) (yield ())+ -- | Like 'concatMap' but uses an 'Unfold' for stream generation. Unlike -- 'concatMap' this can fuse the 'Unfold' code with the inner loop and -- therefore provide many times better performance.@@ -2623,7 +2863,7 @@ -- | Like 'concatUnfold' but interleaves the streams in the same way as -- 'interleave' behaves instead of appending them. ----- @since 0.7.0+-- /Internal/ {-# INLINE concatUnfoldInterleave #-} concatUnfoldInterleave ::(IsStream t, Monad m) => Unfold m a b -> t m a -> t m b@@ -2633,7 +2873,7 @@ -- | Like 'concatUnfold' but executes the streams in the same way as -- 'roundrobin'. ----- @since 0.7.0+-- /Internal/ {-# INLINE concatUnfoldRoundrobin #-} concatUnfoldRoundrobin ::(IsStream t, Monad m) => Unfold m a b -> t m a -> t m b@@ -2676,6 +2916,7 @@ -- >>> intercalate " " UF.fromList ["abc", "def", "ghi"] -- > "abc def ghi" --+-- /Internal/ {-# INLINE intercalate #-} intercalate :: (IsStream t, Monad m) => b -> Unfold m b c -> t m b -> t m c@@ -2718,6 +2959,7 @@ -- >>> intercalate "\n" UF.fromList ["abc", "def", "ghi"] -- > "abc\ndef\nghi\n" --+-- /Internal/ {-# INLINE intercalateSuffix #-} intercalateSuffix :: (IsStream t, Monad m) => b -> Unfold m b c -> t m b -> t m c@@ -2868,6 +3110,31 @@ concatMapTreeYieldLeavesWith combine f = concatMapLoopWith combine f yield ------------------------------------------------------------------------------+-- Parsing+------------------------------------------------------------------------------++-- Splitting operations that take a predicate and a Fold can be+-- expressed using splitParse. Operations like chunksOf, intervalsOf, split*,+-- can be expressed using splitParse when used with an appropriate Parse.+--+-- | Apply a 'Parse' repeatedly on a stream and emit the parsed values in the+-- output stream.+--+-- >>> S.toList $ S.splitParse (PR.take 2 $ PR.fromFold FL.sum) $ S.fromList [1..10]+-- > [3,7,11,15,19]+--+-- >>> S.toList $ S.splitParse (PR.line FL.toList) $ S.fromList "hello\nworld"+-- > ["hello\n","world"]+--+{-# INLINE splitParse #-}+splitParse+ :: (IsStream t, MonadThrow m)+ => Parser m a b+ -> t m a+ -> t m b+splitParse f m = D.fromStreamD $ D.splitParse f (D.toStreamD m)++------------------------------------------------------------------------------ -- Grouping/Splitting ------------------------------------------------------------------------------ @@ -2880,54 +3147,6 @@ ------------------------------------------------------------------------------ -- --- | @splitAt n f1 f2@ composes folds @f1@ and @f2@ such that first @n@--- elements of its input are consumed by fold @f1@ and the rest of the stream--- is consumed by fold @f2@.------ > let splitAt_ n xs = S.fold (FL.splitAt n FL.toList FL.toList) $ S.fromList xs------ >>> splitAt_ 6 "Hello World!"--- > ("Hello ","World!")------ >>> splitAt_ (-1) [1,2,3]--- > ([],[1,2,3])------ >>> splitAt_ 0 [1,2,3]--- > ([],[1,2,3])------ >>> splitAt_ 1 [1,2,3]--- > ([1],[2,3])------ >>> splitAt_ 3 [1,2,3]--- > ([1,2,3],[])------ >>> splitAt_ 4 [1,2,3]--- > ([1,2,3],[])------ @since 0.7.0---- This can be considered as a two-fold version of 'ltake' where we take both--- the segments instead of discarding the leftover.----{-# INLINE splitAt #-}-splitAt- :: Monad m- => Int- -> Fold m a b- -> Fold m a c- -> Fold m a (b, c)-splitAt n (Fold stepL initialL extractL) (Fold stepR initialR extractR) =- Fold step initial extract- where- initial = Tuple3' <$> return n <*> initialL <*> initialR-- step (Tuple3' i xL xR) input =- if i > 0- then stepL xL input >>= (\a -> return (Tuple3' (i - 1) a xR))- else stepR xR input >>= (\b -> return (Tuple3' i xL b))-- extract (Tuple3' _ a b) = (,) <$> extractL a <*> extractR b- ------------------------------------------------------------------------------ -- N-ary APIs ------------------------------------------------------------------------------@@ -2987,6 +3206,9 @@ => Int -> Fold m a b -> t m a -> t m b chunksOf n f m = D.fromStreamD $ D.groupsOf n f (D.toStreamD m) +-- |+--+-- /Internal/ {-# INLINE chunksOf2 #-} chunksOf2 :: (IsStream t, Monad m)@@ -3000,7 +3222,7 @@ -- -- > arraysOf n = S.chunksOf n (A.writeN n) ----- @since 0.7.0+-- /Internal/ {-# INLINE arraysOf #-} arraysOf :: (IsStream t, MonadIO m, Storable a) => Int -> t m a -> t m (Array a)@@ -3024,141 +3246,6 @@ (interjectSuffix n (return Nothing) (Serial.map Just xs)) --------------------------------------------------------------------------------- Element Aware APIs-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Binary APIs----------------------------------------------------------------------------------- | Break the input stream into two groups, the first group takes the input as--- long as the predicate applied to the first element of the stream and next--- input element holds 'True', the second group takes the rest of the input.----spanBy- :: Monad m- => (a -> a -> Bool)- -> Fold m a b- -> Fold m a c- -> Fold m a (b, c)-spanBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =- Fold step initial extract-- where- initial = Tuple3' <$> initialL <*> initialR <*> return (Tuple' Nothing True)-- step (Tuple3' a b (Tuple' (Just frst) isFirstG)) input =- if cmp frst input && isFirstG- then stepL a input- >>= (\a' -> return (Tuple3' a' b (Tuple' (Just frst) isFirstG)))- else stepR b input- >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False)))-- step (Tuple3' a b (Tuple' Nothing isFirstG)) input =- if isFirstG- then stepL a input- >>= (\a' -> return (Tuple3' a' b (Tuple' (Just input) isFirstG)))- else stepR b input- >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False)))-- extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b---- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the--- input as long as the predicate @p@ is 'True'. @f2@ consumes the rest of the--- input.------ > let span_ p xs = S.fold (S.span p FL.toList FL.toList) $ S.fromList xs------ >>> span_ (< 1) [1,2,3]--- > ([],[1,2,3])------ >>> span_ (< 2) [1,2,3]--- > ([1],[2,3])------ >>> span_ (< 4) [1,2,3]--- > ([1,2,3],[])------ @since 0.7.0---- This can be considered as a two-fold version of 'ltakeWhile' where we take--- both the segments instead of discarding the leftover.-{-# INLINE span #-}-span- :: Monad m- => (a -> Bool)- -> Fold m a b- -> Fold m a c- -> Fold m a (b, c)-span p (Fold stepL initialL extractL) (Fold stepR initialR extractR) =- Fold step initial extract-- where-- initial = Tuple3' <$> initialL <*> initialR <*> return True-- step (Tuple3' a b isFirstG) input =- if isFirstG && p input- then stepL a input >>= (\a' -> return (Tuple3' a' b True))- else stepR b input >>= (\a' -> return (Tuple3' a a' False))-- extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b---- |--- > break p = span (not . p)------ Break as soon as the predicate becomes 'True'. @break p f1 f2@ composes--- folds @f1@ and @f2@ such that @f1@ stops consuming input as soon as the--- predicate @p@ becomes 'True'. The rest of the input is consumed @f2@.------ This is the binary version of 'splitBy'.------ > let break_ p xs = S.fold (S.break p FL.toList FL.toList) $ S.fromList xs------ >>> break_ (< 1) [3,2,1]--- > ([3,2,1],[])------ >>> break_ (< 2) [3,2,1]--- > ([3,2],[1])------ >>> break_ (< 4) [3,2,1]--- > ([],[3,2,1])------ @since 0.7.0-{-# INLINE break #-}-break- :: Monad m- => (a -> Bool)- -> Fold m a b- -> Fold m a c- -> Fold m a (b, c)-break p = span (not . p)---- | Like 'spanBy' but applies the predicate in a rolling fashion i.e.--- predicate is applied to the previous and the next input elements.-{-# INLINE spanByRolling #-}-spanByRolling- :: Monad m- => (a -> a -> Bool)- -> Fold m a b- -> Fold m a c- -> Fold m a (b, c)-spanByRolling cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =- Fold step initial extract-- where- initial = Tuple3' <$> initialL <*> initialR <*> return Nothing-- step (Tuple3' a b (Just frst)) input =- if cmp input frst- then stepL a input >>= (\a' -> return (Tuple3' a' b (Just input)))- else stepR b input >>= (\b' -> return (Tuple3' a b' (Just input)))-- step (Tuple3' a b Nothing) input =- stepL a input >>= (\a' -> return (Tuple3' a' b (Just input)))-- extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b-------------------------------------------------------------------------------- -- N-ary APIs ------------------------------------------------------------------------------ --@@ -3217,26 +3304,6 @@ groups = groupsBy (==) --------------------------------------------------------------------------------- Binary splitting on a separator---------------------------------------------------------------------------------{---- | Find the first occurrence of the specified sequence in the input stream--- and break the input stream into two parts, the first part consisting of the--- stream before the sequence and the second part consisting of the sequence--- and the rest of the stream.------ > let breakOn_ pat xs = S.fold (S.breakOn pat FL.toList FL.toList) $ S.fromList xs------ >>> breakOn_ "dear" "Hello dear world!"--- > ("Hello ","dear world!")----{-# INLINE breakOn #-}-breakOn :: Monad m => Array a -> Fold m a b -> Fold m a c -> Fold m a (b,c)-breakOn pat f m = undefined--}-------------------------------------------------------------------------------- -- N-ary split on a predicate ------------------------------------------------------------------------------ @@ -3493,7 +3560,7 @@ -- -- > splitOn . intercalate == id ----- @since 0.7.0+-- /Internal/ -- XXX We can use a polymorphic vector implemented by Array# to represent the -- sequence, that way we can avoid the Storable constraint. If we still need@@ -3547,7 +3614,7 @@ -- -- > lines = splitSuffixOn "\n" ----- @since 0.7.0+-- /Internal/ {-# INLINE splitOnSuffixSeq #-} splitOnSuffixSeq :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)@@ -3598,7 +3665,7 @@ -- >>> splitOn'_ "ll" "hello" -- > ["he","ll","o"] ----- @since 0.7.0+-- /Internal/ {-# INLINE splitBySeq #-} splitBySeq :: (IsStream t, MonadAsync m, Storable a, Enum a, Eq a)@@ -3634,7 +3701,7 @@ -- >>> splitSuffixOn'_ "." "a..b.." -- > ["a.",".","b.","."] ----- @since 0.7.0+-- /Internal/ {-# INLINE splitWithSuffixSeq #-} splitWithSuffixSeq :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)@@ -3657,17 +3724,19 @@ -- Nested Split ------------------------------------------------------------------------------ --- | Consider a chunked stream of container elements e.g. a stream of @Word8@--- chunked as a stream of arrays of @Word8@. @splitInnerBy splitter joiner--- stream@ splits the inner containers @f a@ using the @splitter@ function and--- joins back the resulting fragments from splitting across multiple containers--- using the @joiner@ function such that the transformed output stream is--- consolidated as one container per segment of the split.+-- | @splitInnerBy splitter joiner stream@ splits the inner containers @f a@ of+-- an input stream @t m (f a)@ using the @splitter@ function. Container+-- elements @f a@ are collected until a split occurs, then all the elements+-- before the split are joined using the @joiner@ function. --+-- For example, if we have a stream of @Array Word8@, we may want to split the+-- stream into arrays representing lines separated by '\n' byte such that the+-- resulting stream after a split would be one array for each line.+-- -- CAUTION! This is not a true streaming function as the container size after -- the split and merge may not be bounded. ----- @since 0.7.0+-- /Internal/ {-# INLINE splitInnerBy #-} splitInnerBy :: (IsStream t, Monad m)@@ -3681,7 +3750,7 @@ -- | Like 'splitInnerBy' but splits assuming the separator joins the segment in -- a suffix style. ----- @since 0.7.0+-- /Internal/ {-# INLINE splitInnerBySuffix #-} splitInnerBySuffix :: (IsStream t, Monad m, Eq (f a), Monoid (f a))@@ -3802,7 +3871,7 @@ -- -- Note: This may not work correctly on 32-bit machines. ----- /Internal+-- /Internal/ -- {-# INLINE pollCounts #-} pollCounts ::@@ -3833,7 +3902,7 @@ -- -- Note: This may not work correctly on 32-bit machines. ----- /Internal+-- /Internal/ {-# INLINE tapRate #-} tapRate :: (IsStream t, MonadAsync m, MonadCatch m)@@ -4487,3 +4556,16 @@ {-# INLINE runStateT #-} runStateT :: Monad m => s -> SerialT (StateT s m) a -> SerialT m (s, a) runStateT s xs = fromStreamD $ D.runStateT s (toStreamD xs)++-- | Run a stream transformation using a given environment.+--+-- / Internal/+--+{-# INLINE usingReaderT #-}+usingReaderT+ :: (Monad m, IsStream t)+ => r+ -> (t (ReaderT r m) a -> t (ReaderT r m) a)+ -> t m a+ -> t m a+usingReaderT r f xs = runReaderT r $ f $ liftInner xs
src/Streamly/Network/Socket.hs view
@@ -7,14 +7,60 @@ -- Stability : experimental -- Portability : GHC ----- A socket is a handle to a protocol endpoint.+-- This module provides Array and stream based socket operations to connect to+-- remote hosts, to receive connections from remote hosts, and to read and+-- write streams and arrays of bytes to and from network sockets. ----- This module provides APIs to read and write streams and arrays from and to--- network sockets. Sockets may be connected or unconnected. Connected sockets--- can only send or recv data to/from the connected endpoint, therefore, APIs--- for connected sockets do not need to explicitly specify the remote endpoint.--- APIs for unconnected sockets need to explicitly specify the remote endpoint.+-- For basic socket types and operations please consult the @Network.Socket@+-- module of the <http://hackage.haskell.org/package/network network> package. --+-- = Examples+--+-- To write a server, use the 'accept' unfold to start listening for+-- connections from clients. 'accept' supplies a stream of connected sockets.+-- We can map an effectful action on this socket stream to handle the+-- connections. The action would typically use socket reading and writing+-- operations to communicate with the remote host. We can read/write a stream+-- of bytes or a stream of chunks of bytes ('Array').+--+-- Following is a short example of a concurrent echo server. Please note that+-- this example can be written more succinctly by using higher level operations+-- from "Streamly.Network.Inet.TCP" module.+--+-- @+-- {-\# LANGUAGE FlexibleContexts #-}+--+-- import Data.Function ((&))+-- import Network.Socket+-- import Streamly.Internal.Network.Socket (handleWithM)+-- import Streamly.Network.Socket (SockSpec(..))+--+-- import Streamly+-- import qualified Streamly.Prelude as S+-- import qualified Streamly.Network.Socket as SK+--+-- main = do+-- let spec = SockSpec+-- { sockFamily = AF_INET+-- , sockType = Stream+-- , sockProto = defaultProtocol+-- , sockOpts = []+-- }+-- addr = SockAddrInet 8090 (tupleToHostAddress (0,0,0,0))+-- in server spec addr+--+-- where+--+-- server spec addr =+-- S.unfold SK.accept (maxListenQueue, spec, addr) -- SerialT IO Socket+-- & parallely . S.mapM (handleWithM echo) -- SerialT IO ()+-- & S.drain -- IO ()+--+-- echo sk =+-- S.unfold SK.readChunks sk -- SerialT IO (Array Word8)+-- & S.fold (SK.writeChunks sk) -- IO ()+-- @+-- -- = Programmer Notes -- -- Read IO requests to connected stream sockets are performed in chunks of@@ -25,9 +71,23 @@ -- -- > import qualified Streamly.Network.Socket as SK ----- For additional, experimental APIs take a look at--- "Streamly.Internal.Network.Socket" module.+-- = See Also+--+-- * "Streamly.Internal.Network.Socket"+-- * <http://hackage.haskell.org/package/network network> +-------------------------------------------------------------------------------+-- Internal Notes+-------------------------------------------------------------------------------+--+-- A socket is a handle to a protocol endpoint.+--+-- This module provides APIs to read and write streams and arrays from and to+-- network sockets. Sockets may be connected or unconnected. Connected sockets+-- can only send or recv data to/from the connected endpoint, therefore, APIs+-- for connected sockets do not need to explicitly specify the remote endpoint.+-- APIs for unconnected sockets need to explicitly specify the remote endpoint.+-- -- By design, connected socket IO APIs are similar to -- "Streamly.Memory.Array" read write APIs. They are almost identical to the -- sequential streaming APIs in "Streamly.Internal.FileSystem.File".
src/Streamly/Prelude.hs view
@@ -174,8 +174,6 @@ -- ** Right Folds -- $rightfolds , foldrM- -- , foldrS- -- , foldrT , foldr -- ** Left Folds@@ -199,7 +197,6 @@ , length , sum , product- --, mconcat -- -- ** To Summary (Maybe) (Full Folds) -- -- | Folds that summarize a non-empty stream to a 'Just' value and return@@ -209,7 +206,6 @@ , minimumBy , minimum , the- -- , toListRev -- experimental -- ** Lazy Folds --@@ -252,19 +248,13 @@ , eqBy , cmpBy , isPrefixOf- -- , isSuffixOf- -- , isInfixOf , isSubsequenceOf -- trimming sequences , stripPrefix- -- , stripSuffix- -- , stripInfix -- * Transformation - --, transform- -- ** Mapping -- | In imperative terms a map operation can be considered as a loop over -- the stream that transforms the stream into another stream by performing@@ -343,8 +333,6 @@ , scanlM' , postscanl' , postscanlM'- -- , prescanl'- -- , prescanlM' , scanl1' , scanl1M' @@ -352,16 +340,6 @@ , scan , postscan - -- , lscanl'- -- , lscanlM'- -- , lscanl1'- -- , lscanl1M'- --- -- , lpostscanl'- -- , lpostscanlM'- -- , lprescanl'- -- , lprescanlM'- -- ** Filtering -- | Remove some elements from the stream based on a predicate. In -- imperative terms a filter over a stream corresponds to a loop with a@@ -380,9 +358,6 @@ -- | Deleting elements is a special case of de-interleaving streams. , deleteBy , uniq- -- , uniqBy -- by predicate e.g. to remove duplicate "/" in a path- -- , uniqOn -- to remove duplicate sequences- -- , pruneBy -- dropAround + uniqBy - like words -- ** Inserting Elements -- | Inserting elements is a special case of interleaving/merging streams.@@ -390,73 +365,27 @@ , insertBy , intersperseM , intersperse- -- , insertAfterEach- -- , intersperseBySpan- -- , intersperseByIndices -- using an index function/stream- -- , intersperseByTime- -- , intersperseByEvent - -- -- * Inserting Streams in Streams- -- , interposeBy- -- , intercalate- -- ** Indexing -- | Indexing can be considered as a special type of zipping where we zip a -- stream with an index stream. , indexed , indexedR- -- , timestamped- -- , timestampedR -- timer -- ** Reordering Elements , reverse- -- , reverse' -- ** Trimming -- | Take or remove elements from one or both ends of a stream. , take- -- , takeEnd , takeWhile , takeWhileM- -- , takeWhileEnd , drop- -- , dropEnd , dropWhile , dropWhileM- -- , dropWhileEnd- -- , dropAround -- -- ** Breaking - -- By chunks- -- , splitAt -- spanN- -- , splitIn -- sessionN-- -- By elements- -- , span -- spanWhile- -- , break -- breakBefore- -- , breakAfter- -- , breakOn- -- , breakAround- -- , spanBy- -- , spanByRolling-- -- By sequences- -- breakOnSeq/breakOnArray -- on a fixed sequence- -- breakOnStream -- on a stream-- -- ** Slicing- -- | Streams can be sliced into segments in space or in time. We use the- -- term @chunk@ to refer to a spatial length of the stream (spatial window)- -- and the term @session@ to refer to a length in time (time window).-- -- In imperative terms, grouped folding can be considered as a nested loop- -- where we loop over the stream to group elements and then loop over- -- individual groups to fold them to a single value that is yielded in the- -- output stream.-- -- , groupScan- , chunksOf , intervalsOf @@ -468,15 +397,6 @@ , findIndices , elemIndices - -- -- *** Searching Sequences- -- , seqIndices -- search a sequence in the stream-- -- -- *** Searching Multiple Sequences- -- , seqIndices -- search a sequence in the stream-- -- -- ** Searching Streams- -- -- | Finding a stream within another stream.- -- ** Splitting -- | In general we can express splitting in terms of parser combinators. -- These are some common use functions for convenience and efficiency.@@ -502,32 +422,10 @@ -- -- ** Splitting By Elements , splitOn , splitOnSuffix- -- , splitOnPrefix - -- , splitBy , splitWithSuffix- -- , splitByPrefix , wordsBy -- strip, compact and split - -- -- *** Splitting By Sequences- -- , splitOnSeq- -- , splitOnSuffixSeq- -- , splitOnPrefixSeq-- -- Keeping the delimiters- -- , splitBySeq- -- , splitBySeqSuffix- -- , splitBySeqPrefix- -- , wordsBySeq-- -- Splitting By Multiple Sequences- -- , splitOnAnySeq- -- , splitOnAnySuffixSeq- -- , splitOnAnyPrefixSeq-- -- -- ** Splitting By Streams- -- -- | Splitting a stream using another stream as separator.- -- ** Grouping -- | Splitting a stream by combining multiple contiguous elements into -- groups using some criterion.@@ -535,40 +433,6 @@ , groupsBy , groupsByRolling - {-- -- * Windowed Classification- -- | Split the stream into windows or chunks in space or time. Each window- -- can be associated with a key, all events associated with a particular- -- key in the window can be folded to a single result. The stream is split- -- into windows of specified size, the window can be terminated early if- -- the closing flag is specified in the input stream.- --- -- The term "chunk" is used for a space window and the term "session" is- -- used for a time window.-- -- ** Tumbling Windows- -- | A new window starts after the previous window is finished.- -- , classifyChunksOf- -- , classifySessionsOf-- -- ** Keep Alive Windows- -- | The window size is extended if an event arrives within the specified- -- window size. This can represent sessions with idle or inactive timeout.- -- , classifyKeepAliveChunks- -- , classifyKeepAliveSessions-- {-- -- ** Sliding Windows- -- | A new window starts after the specified slide from the previous- -- window. Therefore windows can overlap.- , classifySlidingChunks- , classifySlidingSessions- -}- -- ** Sliding Window Buffers- -- , slidingChunkBuffer- -- , slidingSessionBuffer- -}- -- * Combining Streams -- | New streams can be constructed by appending, merging or zipping -- existing streams.@@ -660,9 +524,7 @@ -- > filter p m = S.concatMap (\x -> if p x then S.yield x else S.nil) m -- - -- XXX add stateful concatMapWith , concatMapWith- --, bindWith , concatMap , concatMapM , concatUnfold
streamly.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: streamly-version: 0.7.1+version: 0.7.2 synopsis: Beautiful Streaming, Concurrent and Reactive Composition description: Streamly is a framework for writing programs in a high level, declarative@@ -86,6 +86,7 @@ , GHC==8.4.4 , GHC==8.6.5 , GHC==8.8.1+ , GHC==8.10.1 author: Harendra Kumar maintainer: streamly@composewell.com copyright: 2017 Harendra Kumar@@ -119,6 +120,17 @@ configure.ac configure src/Streamly/Internal/Data/Time/config.h.in+ benchmark/streamly-benchmarks.cabal+ benchmark/README.md+ benchmark/*.hs+ benchmark/lib/Streamly/Benchmark/*.hs+ benchmark/Streamly/Benchmark/Memory/*.hs+ benchmark/Streamly/Benchmark/Data/*.hs+ benchmark/Streamly/Benchmark/Data/Prim/*.hs+ benchmark/Streamly/Benchmark/Data/Stream/*.hs+ benchmark/Streamly/Benchmark/FileIO/*.hs+ benchmark/Streamly/Benchmark/Prelude/*.hs+ benchmark/Streamly/Benchmark/Prelude/Serial/*.hs extra-tmp-files: config.log@@ -155,11 +167,6 @@ manual: True default: False -flag no-charts- description: Disable benchmark charts in development build- manual: True- default: False- flag no-fusion description: Disable rewrite rules for stream fusion manual: True@@ -259,28 +266,6 @@ build-depends: fusion-plugin >= 0.2 && < 0.3 --- Some benchmarks are threaded some are not--- XXX dependencies should be separated under bench-depends-common bench-options- import: compile-options, optimization-options- ghc-options: -with-rtsopts "-T -K32K -M16M"- if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)- ghc-options: -fplugin Fusion.Plugin- build-depends:- fusion-plugin >= 0.2 && < 0.3- build-depends: mtl >= 2.2 && < 3--common bench-options-threaded- import: compile-options, optimization-options- -- -threaded and -N2 is important because some GC and space leak issues- -- trigger only with these options.- ghc-options: -threaded -with-rtsopts "-T -N2 -K32K -M16M"- if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)- ghc-options: -fplugin Fusion.Plugin- build-depends:- fusion-plugin >= 0.2 && < 0.3- build-depends: mtl >= 2.2 && < 3- ------------------------------------------------------------------------------- -- Library -------------------------------------------------------------------------------@@ -340,6 +325,9 @@ , Streamly.Internal.Memory.ArrayStream , Streamly.Internal.Data.Fold.Types , Streamly.Internal.Data.Fold+ , Streamly.Internal.Data.Parser+ , Streamly.Internal.Data.Parser.Types+ , Streamly.Internal.Data.Parser.Tee , Streamly.Internal.Data.Sink.Types , Streamly.Internal.Data.Sink @@ -394,7 +382,7 @@ , deepseq >= 1.4.1 && < 1.5 , directory >= 1.2.2 && < 1.4 , exceptions >= 0.8 && < 0.11- , ghc-prim >= 0.2 && < 0.6+ , ghc-prim >= 0.2 && < 0.7 , mtl >= 2.2 && < 3 , primitive >= 0.5.4 && < 0.8 , transformers >= 0.4 && < 0.6@@ -419,7 +407,7 @@ semigroups >= 0.18 && < 0.19 if flag(inspection)- build-depends: template-haskell >= 2.14 && < 2.16+ build-depends: template-haskell >= 2.14 && < 2.17 , inspection-testing >= 0.4 && < 0.5 -- Array uses a Storable constraint in dev build making several inspection@@ -456,7 +444,7 @@ build-depends: streamly , base >= 4.8 && < 5- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 , hspec >= 2.0 && < 3 default-language: Haskell2010 @@ -492,7 +480,7 @@ build-depends: streamly , base >= 4.8 && < 5- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 , hspec >= 2.0 && < 3 if impl(ghc < 8.0) build-depends:@@ -509,7 +497,7 @@ build-depends: streamly , base >= 4.8 && < 5- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 , hspec >= 2.0 && < 3 if impl(ghc < 8.0) build-depends:@@ -526,7 +514,7 @@ streamly , base >= 4.8 && < 5 , hspec >= 2.0 && < 3- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 default-language: Haskell2010 test-suite data-array-test@@ -538,7 +526,7 @@ build-depends: streamly , base >= 4.8 && < 5- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 , hspec >= 2.0 && < 3 if impl(ghc < 8.0) build-depends:@@ -555,7 +543,7 @@ build-depends: streamly , base >= 4.8 && < 5- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 , hspec >= 2.0 && < 3 if impl(ghc < 8.0) build-depends:@@ -572,7 +560,7 @@ build-depends: streamly , base >= 4.8 && < 5- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 , hspec >= 2.0 && < 3 if impl(ghc < 8.0) build-depends:@@ -588,7 +576,7 @@ build-depends: streamly , base >= 4.8 && < 5- , QuickCheck >= 2.10 && < 2.14+ , QuickCheck >= 2.10 && < 2.15 , hspec >= 2.0 && < 3 if impl(ghc < 8.0) build-depends:@@ -657,320 +645,6 @@ , base >= 4.8 && < 5 ---------------------------------------------------------------------------------- Benchmarks------------------------------------------------------------------------------------ For linear, linear-async, linear-rate, nested and nested-concurrent--- you can pass the number of elements in the stream using the--- --stream-size option:--- $ cabal run linear -- --stream-size 1000000--benchmark linear- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- -- XXX heap/stack limits can be reduced once we split out the buffered- -- benchmarks into a separate suite- ghc-options: -with-rtsopts "-T -K4M -M128M"- main-is: Linear.hs- other-modules: Streamly.Benchmark.Prelude, Common- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6- if flag(inspection)- build-depends: template-haskell >= 2.14 && < 2.16- , inspection-testing >= 0.4 && < 0.5--benchmark nested- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -K256K -M16M"- main-is: Nested.hs- other-modules: NestedOps, Common- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--benchmark nested-unfold- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -K64K -M16M"- main-is: NestedUnfold.hs- other-modules: NestedUnfoldOps, Common- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--benchmark unpinned-array- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -K1K -M128M"- main-is: Streamly/Benchmark/Data/Array.hs- other-modules: Streamly.Benchmark.Data.ArrayOps- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--benchmark prim-array- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -K64K -M32M"- main-is: Streamly/Benchmark/Data/Prim/Array.hs- other-modules: Streamly.Benchmark.Data.Prim.ArrayOps- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--benchmark small-array- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -K128K -M16M"- main-is: Streamly/Benchmark/Data/SmallArray.hs- other-modules: Streamly.Benchmark.Data.SmallArrayOps- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--benchmark array- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -K64K -M128M"- main-is: Array.hs- other-modules: ArrayOps- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--benchmark fileio- import: bench-options- type: exitcode-stdio-1.0- -- A value of 400 works better for some benchmarks, however, it takes- -- extraordinary amount of time to compile with that.- -- ghc-options: -funfolding-use-threshold=150- hs-source-dirs: benchmark- main-is: FileIO.hs- other-modules: Streamly.Benchmark.FileIO.Array- , Streamly.Benchmark.FileIO.Stream- build-depends:- streamly- , base >= 4.8 && < 5- , gauge >= 0.2.4 && < 0.3- , typed-process >= 0.2.3 && < 0.3- , deepseq >= 1.4.1 && < 1.5- if flag(inspection)- build-depends: template-haskell >= 2.14 && < 2.16- , inspection-testing >= 0.4 && < 0.5------------------------------------------------------------------------------------ Threaded Benchmarks----------------------------------------------------------------------------------benchmark linear-async- import: bench-options-threaded- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -N2 -K64K -M16M"- main-is: LinearAsync.hs- other-modules: Streamly.Benchmark.Prelude, Common- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6- if flag(inspection)- build-depends: template-haskell >= 2.14 && < 2.16- , inspection-testing >= 0.4 && < 0.5--benchmark nested-concurrent- import: bench-options-threaded- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- -- XXX this can be lowered once we split out the finite benchmarks- ghc-options: -with-rtsopts "-T -N2 -K256K -M128M"- main-is: NestedConcurrent.hs- other-modules: NestedOps, Common- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--benchmark parallel- import: bench-options-threaded- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- ghc-options: -with-rtsopts "-T -N2 -K128K -M256M"- main-is: Parallel.hs- other-modules: Streamly.Benchmark.Prelude, NestedOps, Common- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6- if flag(inspection)- build-depends: template-haskell >= 2.14 && < 2.16- , inspection-testing >= 0.4 && < 0.5--benchmark linear-rate- import: bench-options-threaded- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- main-is: LinearRate.hs- other-modules: Streamly.Benchmark.Prelude, Common- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6- if flag(inspection)- build-depends: template-haskell >= 2.14 && < 2.16- , inspection-testing >= 0.4 && < 0.5--benchmark concurrent- import: bench-options-threaded- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- main-is: Concurrent.hs- ghc-options: -with-rtsopts "-T -N2 -K256K -M384M"- build-depends:- streamly- , base >= 4.8 && < 5- , gauge >= 0.2.4 && < 0.3------------------------------------------------------------------------------------ Internal benchmarks----------------------------------------------------------------------------------benchmark base- import: bench-options- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- if flag(dev)- cpp-options: -DDEVBUILD- ghc-options: -with-rtsopts "-T -K2M -M16M"- else- ghc-options: -with-rtsopts "-T -K128K -M16M"- main-is: BaseStreams.hs- other-modules: StreamDOps- , StreamKOps- , StreamDKOps-- build-depends:- streamly- , base >= 4.8 && < 5- , deepseq >= 1.4.1 && < 1.5- , random >= 1.0 && < 2.0- , gauge >= 0.2.4 && < 0.3--executable nano-bench- import: bench-options- hs-source-dirs: benchmark- main-is: NanoBenchmarks.hs- if flag(dev)- buildable: True- build-depends:- streamly- , base >= 4.8 && < 5- , gauge >= 0.2.4 && < 0.3- , random >= 1.0 && < 2.0- else- buildable: False--benchmark adaptive- import: bench-options-threaded- type: exitcode-stdio-1.0- hs-source-dirs: benchmark- main-is: Adaptive.hs- default-language: Haskell2010- build-depends:- streamly- , base >= 4.8 && < 5- , gauge >= 0.2.4 && < 0.3- , random >= 1.0 && < 2.0- if impl(ghc < 8.0)- build-depends:- transformers >= 0.4 && < 0.6--executable chart- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: benchmark- main-is: Chart.hs- if flag(dev) && !flag(no-charts) && !impl(ghcjs)- buildable: True- build-Depends:- base >= 4.8 && < 5- , bench-show >= 0.3 && < 0.4- , split- , transformers >= 0.4 && < 0.6- else- buildable: False--------------------------------------------------------------------------------- -- Examples ------------------------------------------------------------------------------- @@ -980,10 +654,13 @@ hs-source-dirs: examples if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs) buildable: True- build-Depends:+ build-depends: streamly- , base >= 4.8 && < 5- , http-conduit >= 2.2.2 && < 2.4+ , base >= 4.8 && < 5+ , http-conduit >= 2.2.2 && < 2.4+ if impl(ghc < 8.0)+ build-depends:+ unliftio-core < 0.2 else buildable: False
test/Main.hs view
@@ -6,7 +6,7 @@ module Main (main) where import Control.Concurrent (threadDelay)-import Control.Exception (Exception, try, ErrorCall(..), catch, throw)+import Control.Exception (Exception, try, ErrorCall(..), catch) import Control.Monad (void) import Control.Monad.Catch (throwM, MonadThrow) import Control.Monad.Error.Class (throwError, MonadError)@@ -14,7 +14,9 @@ import Control.Monad.State (MonadState, get, modify, runStateT, StateT) import Control.Monad.Trans.Except (runExceptT, ExceptT) import Data.Foldable (forM_, fold)+import Data.Function ((&)) import Data.List (sort)+import Data.Maybe (fromJust, isJust) import System.Mem (performMajorGC) import Data.IORef@@ -147,6 +149,7 @@ describe "Parallel (<>) time order check" $ parallelCheck parallely (<>) describe "Parallel mappend time order check" $ parallelCheck parallely mappend+ it "fromCallback" $ testFromCallback `shouldReturn` (50*101) checkCleanup :: IsStream t => Int@@ -655,9 +658,7 @@ let s = return (1 :: Int) `S.consM` error "failure" catch (S.foldx (\_ a -> if a == 1 then error "success" else "done") "begin" id s)- (\e -> case e of- ErrorCall err -> return err- _ -> throw e)+ (\(ErrorCall err) -> return err) `shouldReturn` "success" #endif @@ -666,9 +667,7 @@ let s = return (1 :: Int) `S.consM` error "failure" catch (S.foldl' (\_ a -> if a == 1 then error "success" else "done") "begin" s)- (\e -> case e of- ErrorCall err -> return err- _ -> throw e)+ (\(ErrorCall err) -> return err) `shouldReturn` "success" #ifdef DEVBUILD@@ -685,9 +684,7 @@ ) >> return "finished" )- (\e -> case e of- ErrorCall err -> return err- _ -> throw e)+ (\(ErrorCall err) -> return err) `shouldReturn` "success" #endif @@ -705,9 +702,7 @@ s) >> return "finished" )- (\e -> case e of- ErrorCall err -> return err- _ -> throw e)+ (\(ErrorCall err) -> return err) `shouldReturn` "success" foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO ()@@ -1150,3 +1145,28 @@ return (x11 + y11 + z11) return (x1 + y1 + z1) return (x + y + z)++testFromCallback :: IO Int+testFromCallback = do+ ref <- newIORef Nothing+ let stream = S.map Just (IP.fromCallback (setCallback ref))+ `Streamly.parallel` runCallback ref+ S.sum $ S.map fromJust $ S.takeWhile isJust stream++ where++ setCallback ref cb = do+ writeIORef ref (Just cb)++ runCallback ref = S.yieldM $ do+ cb <-+ S.repeatM (readIORef ref)+ & IP.delayPost 0.1+ & S.mapMaybe id+ & S.head++ S.fromList [1..100]+ & IP.delayPost 0.001+ & S.mapM_ (fromJust cb)+ threadDelay 100000+ return Nothing
test/Streamly/Test/Array.hs view
@@ -149,6 +149,13 @@ $ S.fold (A.lastN n) $ S.fromList list assert (xs == lastN n list)++testLastN_LN :: Int -> Int -> IO Bool+testLastN_LN len n = do+ let list = [1..len]+ l1 <- fmap A.toList $ S.fold (A.lastN n) $ S.fromList list+ let l2 = lastN n list+ return $ l1 == l2 #endif main :: IO ()@@ -174,5 +181,10 @@ #endif #ifdef TEST_ARRAY describe "Fold" $ do- prop "lastN" $ testLastN+ prop "lastN : 0 <= n <= len" $ testLastN+ describe "lastN boundary conditions" $ do+ it "lastN -1" (testLastN_LN 10 (-1) `shouldReturn` True)+ it "lastN 0" (testLastN_LN 10 0 `shouldReturn` True)+ it "lastN length" (testLastN_LN 10 10 `shouldReturn` True)+ it "lastN (length + 1)" (testLastN_LN 10 11 `shouldReturn` True) #endif