diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 diff --git a/bench.sh b/bench.sh --- a/bench.sh +++ b/bench.sh @@ -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 diff --git a/benchmark/Adaptive.hs b/benchmark/Adaptive.hs deleted file mode 100644 --- a/benchmark/Adaptive.hs +++ /dev/null @@ -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 - ] - ] diff --git a/benchmark/Array.hs b/benchmark/Array.hs deleted file mode 100644 --- a/benchmark/Array.hs +++ /dev/null @@ -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 - ] - -} - ] - ] diff --git a/benchmark/ArrayOps.hs b/benchmark/ArrayOps.hs deleted file mode 100644 --- a/benchmark/ArrayOps.hs +++ /dev/null @@ -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 --} diff --git a/benchmark/BaseStreams.hs b/benchmark/BaseStreams.hs deleted file mode 100644 --- a/benchmark/BaseStreams.hs +++ /dev/null @@ -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 - ] - ] - ] diff --git a/benchmark/Chart.hs b/benchmark/Chart.hs --- a/benchmark/Chart.hs +++ b/benchmark/Chart.hs @@ -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" diff --git a/benchmark/Common.hs b/benchmark/Common.hs deleted file mode 100644 --- a/benchmark/Common.hs +++ /dev/null @@ -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) diff --git a/benchmark/Concurrent.hs b/benchmark/Concurrent.hs deleted file mode 100644 --- a/benchmark/Concurrent.hs +++ /dev/null @@ -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) - ] diff --git a/benchmark/FileIO.hs b/benchmark/FileIO.hs --- a/benchmark/FileIO.hs +++ b/benchmark/FileIO.hs @@ -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 diff --git a/benchmark/Linear.hs b/benchmark/Linear.hs deleted file mode 100644 --- a/benchmark/Linear.hs +++ /dev/null @@ -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 - ] - ] diff --git a/benchmark/LinearAsync.hs b/benchmark/LinearAsync.hs deleted file mode 100644 --- a/benchmark/LinearAsync.hs +++ /dev/null @@ -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 - ] - ] diff --git a/benchmark/LinearRate.hs b/benchmark/LinearRate.hs deleted file mode 100644 --- a/benchmark/LinearRate.hs +++ /dev/null @@ -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) - ] - ] - ] diff --git a/benchmark/Nested.hs b/benchmark/Nested.hs deleted file mode 100644 --- a/benchmark/Nested.hs +++ /dev/null @@ -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 - ] - ] diff --git a/benchmark/NestedConcurrent.hs b/benchmark/NestedConcurrent.hs deleted file mode 100644 --- a/benchmark/NestedConcurrent.hs +++ /dev/null @@ -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 - ] - ] - ] diff --git a/benchmark/NestedOps.hs b/benchmark/NestedOps.hs deleted file mode 100644 --- a/benchmark/NestedOps.hs +++ /dev/null @@ -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)) diff --git a/benchmark/NestedUnfold.hs b/benchmark/NestedUnfold.hs deleted file mode 100644 --- a/benchmark/NestedUnfold.hs +++ /dev/null @@ -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 - ] - ] diff --git a/benchmark/NestedUnfoldOps.hs b/benchmark/NestedUnfoldOps.hs deleted file mode 100644 --- a/benchmark/NestedUnfoldOps.hs +++ /dev/null @@ -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) diff --git a/benchmark/Parallel.hs b/benchmark/Parallel.hs deleted file mode 100644 --- a/benchmark/Parallel.hs +++ /dev/null @@ -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 - ] - ] diff --git a/benchmark/README.md b/benchmark/README.md new file mode 100644 --- /dev/null +++ b/benchmark/README.md @@ -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. diff --git a/benchmark/StreamDKOps.hs b/benchmark/StreamDKOps.hs deleted file mode 100644 --- a/benchmark/StreamDKOps.hs +++ /dev/null @@ -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 [] --} diff --git a/benchmark/StreamDOps.hs b/benchmark/StreamDOps.hs deleted file mode 100644 --- a/benchmark/StreamDOps.hs +++ /dev/null @@ -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 diff --git a/benchmark/StreamKOps.hs b/benchmark/StreamKOps.hs deleted file mode 100644 --- a/benchmark/StreamKOps.hs +++ /dev/null @@ -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 [] diff --git a/benchmark/Streamly/Benchmark/Data/Fold.hs b/benchmark/Streamly/Benchmark/Data/Fold.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Fold.hs @@ -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]] + ] diff --git a/benchmark/Streamly/Benchmark/Data/NestedUnfoldOps.hs b/benchmark/Streamly/Benchmark/Data/NestedUnfoldOps.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/NestedUnfoldOps.hs @@ -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) diff --git a/benchmark/Streamly/Benchmark/Data/Parser.hs b/benchmark/Streamly/Benchmark/Data/Parser.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Parser.hs @@ -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 + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/BaseStreams.hs b/benchmark/Streamly/Benchmark/Data/Stream/BaseStreams.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Stream/BaseStreams.hs @@ -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 diff --git a/benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs b/benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs @@ -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 + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs b/benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs @@ -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 + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs b/benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs @@ -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) + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/Unfold.hs b/benchmark/Streamly/Benchmark/Data/Unfold.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Unfold.hs @@ -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)] + ] diff --git a/benchmark/Streamly/Benchmark/FileIO/Stream.hs b/benchmark/Streamly/Benchmark/FileIO/Stream.hs --- a/benchmark/Streamly/Benchmark/FileIO/Stream.hs +++ b/benchmark/Streamly/Benchmark/FileIO/Stream.hs @@ -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 #-} diff --git a/benchmark/Streamly/Benchmark/Memory/Array.hs b/benchmark/Streamly/Benchmark/Memory/Array.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Memory/Array.hs @@ -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 + ] + -} + ] + ] diff --git a/benchmark/Streamly/Benchmark/Memory/ArrayOps.hs b/benchmark/Streamly/Benchmark/Memory/ArrayOps.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Memory/ArrayOps.hs @@ -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 +-} diff --git a/benchmark/Streamly/Benchmark/Prelude.hs b/benchmark/Streamly/Benchmark/Prelude.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Prelude.hs +++ /dev/null @@ -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 diff --git a/benchmark/Streamly/Benchmark/Prelude/Adaptive.hs b/benchmark/Streamly/Benchmark/Prelude/Adaptive.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/Adaptive.hs @@ -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 + ] + ] diff --git a/benchmark/Streamly/Benchmark/Prelude/Concurrent.hs b/benchmark/Streamly/Benchmark/Prelude/Concurrent.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/Concurrent.hs @@ -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) + ] diff --git a/benchmark/Streamly/Benchmark/Prelude/LinearAsync.hs b/benchmark/Streamly/Benchmark/Prelude/LinearAsync.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/LinearAsync.hs @@ -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 diff --git a/benchmark/Streamly/Benchmark/Prelude/LinearRate.hs b/benchmark/Streamly/Benchmark/Prelude/LinearRate.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/LinearRate.hs @@ -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 + ] diff --git a/benchmark/Streamly/Benchmark/Prelude/NestedConcurrent.hs b/benchmark/Streamly/Benchmark/Prelude/NestedConcurrent.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/NestedConcurrent.hs @@ -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 + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Prelude/NestedOps.hs b/benchmark/Streamly/Benchmark/Prelude/NestedOps.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/NestedOps.hs @@ -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)) diff --git a/benchmark/Streamly/Benchmark/Prelude/Parallel.hs b/benchmark/Streamly/Benchmark/Prelude/Parallel.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/Parallel.hs @@ -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 diff --git a/benchmark/Streamly/Benchmark/Prelude/Serial/O_1_Space.hs b/benchmark/Streamly/Benchmark/Prelude/Serial/O_1_Space.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/Serial/O_1_Space.hs @@ -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] diff --git a/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Heap.hs b/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Heap.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Heap.hs @@ -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 + ] diff --git a/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Space.hs b/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Space.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Space.hs @@ -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 + ] diff --git a/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Stack.hs b/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Stack.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Stack.hs @@ -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 diff --git a/benchmark/lib/Streamly/Benchmark/Common.hs b/benchmark/lib/Streamly/Benchmark/Common.hs new file mode 100644 --- /dev/null +++ b/benchmark/lib/Streamly/Benchmark/Common.hs @@ -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) diff --git a/benchmark/lib/Streamly/Benchmark/Prelude.hs b/benchmark/lib/Streamly/Benchmark/Prelude.hs new file mode 100644 --- /dev/null +++ b/benchmark/lib/Streamly/Benchmark/Prelude.hs @@ -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) + ] + ] + ] diff --git a/benchmark/streamly-benchmarks.cabal b/benchmark/streamly-benchmarks.cabal new file mode 100644 --- /dev/null +++ b/benchmark/streamly-benchmarks.cabal @@ -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 diff --git a/configure b/configure --- a/configure +++ b/configure @@ -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 . # @@ -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 + diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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]) diff --git a/credits/CONTRIBUTORS.md b/credits/CONTRIBUTORS.md --- a/credits/CONTRIBUTORS.md +++ b/credits/CONTRIBUTORS.md @@ -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 diff --git a/docs/Build.md b/docs/Build.md --- a/docs/Build.md +++ b/docs/Build.md @@ -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 diff --git a/examples/EchoServer.hs b/examples/EchoServer.hs --- a/examples/EchoServer.hs +++ b/examples/EchoServer.hs @@ -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 () diff --git a/examples/WordClassifier.hs b/examples/WordClassifier.hs --- a/examples/WordClassifier.hs +++ b/examples/WordClassifier.hs @@ -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 diff --git a/src/Streamly/FileSystem/IOVec.hsc b/src/Streamly/FileSystem/IOVec.hsc --- a/src/Streamly/FileSystem/IOVec.hsc +++ b/src/Streamly/FileSystem/IOVec.hsc @@ -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 diff --git a/src/Streamly/Internal/Data/Fold.hs b/src/Streamly/Internal/Data/Fold.hs --- a/src/Streamly/Internal/Data/Fold.hs +++ b/src/Streamly/Internal/Data/Fold.hs @@ -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. diff --git a/src/Streamly/Internal/Data/Fold/Types.hs b/src/Streamly/Internal/Data/Fold/Types.hs --- a/src/Streamly/Internal/Data/Fold/Types.hs +++ b/src/Streamly/Internal/Data/Fold/Types.hs @@ -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. diff --git a/src/Streamly/Internal/Data/Parser.hs b/src/Streamly/Internal/Data/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser.hs @@ -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 +-- +-- 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 diff --git a/src/Streamly/Internal/Data/Parser/Tee.hs b/src/Streamly/Internal/Data/Parser/Tee.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/Tee.hs @@ -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" diff --git a/src/Streamly/Internal/Data/Parser/Types.hs b/src/Streamly/Internal/Data/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Parser/Types.hs @@ -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 diff --git a/src/Streamly/Internal/Data/Prim/Array/Types.hs b/src/Streamly/Internal/Data/Prim/Array/Types.hs --- a/src/Streamly/Internal/Data/Prim/Array/Types.hs +++ b/src/Streamly/Internal/Data/Prim/Array/Types.hs @@ -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. --} diff --git a/src/Streamly/Internal/Data/Stream/Combinators.hs b/src/Streamly/Internal/Data/Stream/Combinators.hs --- a/src/Streamly/Internal/Data/Stream/Combinators.hs +++ b/src/Streamly/Internal/Data/Stream/Combinators.hs @@ -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 diff --git a/src/Streamly/Internal/Data/Stream/Parallel.hs b/src/Streamly/Internal/Data/Stream/Parallel.hs --- a/src/Streamly/Internal/Data/Stream/Parallel.hs +++ b/src/Streamly/Internal/Data/Stream/Parallel.hs @@ -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 diff --git a/src/Streamly/Internal/Data/Stream/Prelude.hs b/src/Streamly/Internal/Data/Stream/Prelude.hs --- a/src/Streamly/Internal/Data/Stream/Prelude.hs +++ b/src/Streamly/Internal/Data/Stream/Prelude.hs @@ -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 diff --git a/src/Streamly/Internal/Data/Stream/SVar.hs b/src/Streamly/Internal/Data/Stream/SVar.hs --- a/src/Streamly/Internal/Data/Stream/SVar.hs +++ b/src/Streamly/Internal/Data/Stream/SVar.hs @@ -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 #-} diff --git a/src/Streamly/Internal/Data/Stream/StreamD.hs b/src/Streamly/Internal/Data/Stream/StreamD.hs --- a/src/Streamly/Internal/Data/Stream/StreamD.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD.hs @@ -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 diff --git a/src/Streamly/Internal/Data/Stream/StreamK.hs b/src/Streamly/Internal/Data/Stream/StreamK.hs --- a/src/Streamly/Internal/Data/Stream/StreamK.hs +++ b/src/Streamly/Internal/Data/Stream/StreamK.hs @@ -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 -> diff --git a/src/Streamly/Internal/Data/Stream/StreamK/Type.hs b/src/Streamly/Internal/Data/Stream/StreamK/Type.hs --- a/src/Streamly/Internal/Data/Stream/StreamK/Type.hs +++ b/src/Streamly/Internal/Data/Stream/StreamK/Type.hs @@ -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 diff --git a/src/Streamly/Internal/Data/Time/Clock.hsc b/src/Streamly/Internal/Data/Time/Clock.hsc --- a/src/Streamly/Internal/Data/Time/Clock.hsc +++ b/src/Streamly/Internal/Data/Time/Clock.hsc @@ -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 diff --git a/src/Streamly/Internal/Data/Time/config.h.in b/src/Streamly/Internal/Data/Time/config.h.in --- a/src/Streamly/Internal/Data/Time/config.h.in +++ b/src/Streamly/Internal/Data/Time/config.h.in @@ -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 diff --git a/src/Streamly/Internal/Data/Unfold.hs b/src/Streamly/Internal/Data/Unfold.hs --- a/src/Streamly/Internal/Data/Unfold.hs +++ b/src/Streamly/Internal/Data/Unfold.hs @@ -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 #-} diff --git a/src/Streamly/Internal/Data/Unicode/Char.hs b/src/Streamly/Internal/Data/Unicode/Char.hs --- a/src/Streamly/Internal/Data/Unicode/Char.hs +++ b/src/Streamly/Internal/Data/Unicode/Char.hs @@ -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 diff --git a/src/Streamly/Internal/FileSystem/Dir.hs b/src/Streamly/Internal/FileSystem/Dir.hs --- a/src/Streamly/Internal/FileSystem/Dir.hs +++ b/src/Streamly/Internal/FileSystem/Dir.hs @@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" diff --git a/src/Streamly/Internal/FileSystem/File.hs b/src/Streamly/Internal/FileSystem/File.hs --- a/src/Streamly/Internal/FileSystem/File.hs +++ b/src/Streamly/Internal/FileSystem/File.hs @@ -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 diff --git a/src/Streamly/Internal/FileSystem/Handle.hs b/src/Streamly/Internal/FileSystem/Handle.hs --- a/src/Streamly/Internal/FileSystem/Handle.hs +++ b/src/Streamly/Internal/FileSystem/Handle.hs @@ -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. -- diff --git a/src/Streamly/Internal/Memory/Array.hs b/src/Streamly/Internal/Memory/Array.hs --- a/src/Streamly/Internal/Memory/Array.hs +++ b/src/Streamly/Internal/Memory/Array.hs @@ -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. -- diff --git a/src/Streamly/Internal/Memory/Array/Types.hs b/src/Streamly/Internal/Memory/Array/Types.hs --- a/src/Streamly/Internal/Memory/Array/Types.hs +++ b/src/Streamly/Internal/Memory/Array/Types.hs @@ -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 diff --git a/src/Streamly/Internal/Memory/ArrayStream.hs b/src/Streamly/Internal/Memory/ArrayStream.hs --- a/src/Streamly/Internal/Memory/ArrayStream.hs +++ b/src/Streamly/Internal/Memory/ArrayStream.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} #include "inline.hs" diff --git a/src/Streamly/Internal/Prelude.hs b/src/Streamly/Internal/Prelude.hs --- a/src/Streamly/Internal/Prelude.hs +++ b/src/Streamly/Internal/Prelude.hs @@ -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 diff --git a/src/Streamly/Network/Socket.hs b/src/Streamly/Network/Socket.hs --- a/src/Streamly/Network/Socket.hs +++ b/src/Streamly/Network/Socket.hs @@ -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 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" +-- * +------------------------------------------------------------------------------- +-- 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". diff --git a/src/Streamly/Prelude.hs b/src/Streamly/Prelude.hs --- a/src/Streamly/Prelude.hs +++ b/src/Streamly/Prelude.hs @@ -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 diff --git a/streamly.cabal b/streamly.cabal --- a/streamly.cabal +++ b/streamly.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Streamly/Test/Array.hs b/test/Streamly/Test/Array.hs --- a/test/Streamly/Test/Array.hs +++ b/test/Streamly/Test/Array.hs @@ -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